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 immediate - return is effected. + A (input/output) DOUBLE PRECISION array, dimension (LDA,N) + The m by n matrix A. On exit, A is overwritten by P*A if + SIDE = 'R' or by A*P' if SIDE = 'L'. - C (input) DOUBLE PRECISION array, dimension - (M-1) if SIDE = 'L' (N-1) if SIDE = 'R' The cosines c(k) of the - plane rotations. + LDA (input) INTEGER + The leading dimension of the array A. LDA >= max(1,M). - S (input) DOUBLE PRECISION array, dimension - (M-1) if SIDE = 'L' (N-1) if SIDE = 'R' The sines s(k) of the - plane rotations. The 2-by-2 plane rotation part of the matrix - P(k), R(k), has the form R(k) = ( c(k) s(k) ) ( -s(k) c(k) - ). - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - The M-by-N matrix A. On exit, A is overwritten by P*A if SIDE - = 'R' or by A*P**T if SIDE = 'L'. +\end{chunk} - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). +\begin{verbatim} + SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, 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 DIRECT, PIVOT, SIDE + INTEGER LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + DOUBLE PRECISION CTEMP, STEMP, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN + INFO = 1 + ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, + $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN + INFO = 2 + ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) + $ THEN + INFO = 3 + ELSE IF( M.LT.0 ) THEN + INFO = 4 + ELSE IF( N.LT.0 ) THEN + INFO = 5 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = 9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASR ', INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) + $ RETURN + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form P * A +* + IF( LSAME( PIVOT, 'V' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 20 J = 1, M - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 10 I = 1, N + TEMP = A( J+1, I ) + A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) + A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) + 10 CONTINUE + END IF + 20 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 40 J = M - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 30 I = 1, N + TEMP = A( J+1, I ) + A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) + A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) + 30 CONTINUE + END IF + 40 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'T' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 60 J = 2, M + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 50 I = 1, N + TEMP = A( J, I ) + A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) + A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 80 J = M, 2, -1 + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 70 I = 1, N + TEMP = A( J, I ) + A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) + A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) + 70 CONTINUE + END IF + 80 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'B' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 100 J = 1, M - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 90 I = 1, N + TEMP = A( J, I ) + A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP + A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP + 90 CONTINUE + END IF + 100 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 120 J = M - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 110 I = 1, N + TEMP = A( J, I ) + A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP + A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP + 110 CONTINUE + END IF + 120 CONTINUE + END IF + END IF + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form A * P' +* + IF( LSAME( PIVOT, 'V' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 140 J = 1, N - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 130 I = 1, M + TEMP = A( I, J+1 ) + A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) + A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) + 130 CONTINUE + END IF + 140 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 160 J = N - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 150 I = 1, M + TEMP = A( I, J+1 ) + A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) + A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) + 150 CONTINUE + END IF + 160 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'T' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 180 J = 2, N + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 170 I = 1, M + TEMP = A( I, J ) + A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) + A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) + 170 CONTINUE + END IF + 180 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 200 J = N, 2, -1 + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 190 I = 1, M + TEMP = A( I, J ) + A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) + A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) + 190 CONTINUE + END IF + 200 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'B' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 220 J = 1, N - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 210 I = 1, M + TEMP = A( I, J ) + A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP + A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP + 210 CONTINUE + END IF + 220 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 240 J = N - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 230 I = 1, M + TEMP = A( I, J ) + A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP + A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP + 230 CONTINUE + END IF + 240 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DLASR +* + END -\end{chunk} +\end{verbatim} \begin{chunk}{LAPACK dlasr} (let* ((one 1.0) (zero 0.0)) @@ -67371,33 +94137,256 @@ SYNOPSIS DOUBLE PRECISION D( * ) -PURPOSE - Sort the numbers in D in increasing order (if ID = 'I') or in decreas- - ing order (if ID = 'D' ). + Purpose + ======= - Use Quick Sort, reverting to Insertion sort on arrays of - size <= 20. Dimension of STACK limits N to about 2**32. + Sort the numbers in D in increasing order (if ID = 'I') or + in decreasing order (if ID = 'D' ). + Use Quick Sort, reverting to Insertion sort on arrays of + size <= 20. Dimension of STACK limits N to about 2**32. -ARGUMENTS - ID (input) CHARACTER*1 - = 'I': sort D in increasing order; - = 'D': sort D in decreasing order. + Arguments + ========= - N (input) INTEGER - The length of the array D. + ID (input) CHARACTER*1 + = 'I': sort D in increasing order; + = 'D': sort D in decreasing order. - D (input/output) DOUBLE PRECISION array, dimension (N) - On entry, the array to be sorted. On exit, D has been sorted - into increasing order (D(1) <= ... <= D(N) ) or into decreasing - order (D(1) >= ... >= D(N) ), depending on ID. + N (input) INTEGER + The length of the array D. - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value + D (input/output) DOUBLE PRECISION array, dimension (N) + On entry, the array to be sorted. + On exit, D has been sorted into increasing order + (D(1) <= ... <= D(N) ) or into decreasing order + (D(1) >= ... >= D(N) ), depending on ID. + + INFO (output) INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value \end{chunk} +\begin{verbatim} + SUBROUTINE DLASRT( ID, N, D, 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 ID + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER SELECT + PARAMETER ( SELECT = 20 ) +* .. +* .. Local Scalars .. + INTEGER DIR, ENDD, I, J, START, STKPNT + DOUBLE PRECISION D1, D2, D3, DMNMX, TMP +* .. +* .. Local Arrays .. + INTEGER STACK( 2, 32 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input paramters. +* + INFO = 0 + DIR = -1 + IF( LSAME( ID, 'D' ) ) THEN + DIR = 0 + ELSE IF( LSAME( ID, 'I' ) ) THEN + DIR = 1 + END IF + IF( DIR.EQ.-1 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASRT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* + STKPNT = 1 + STACK( 1, 1 ) = 1 + STACK( 2, 1 ) = N + 10 CONTINUE + START = STACK( 1, STKPNT ) + ENDD = STACK( 2, STKPNT ) + STKPNT = STKPNT - 1 + IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN +* +* Do Insertion sort on D( START:ENDD ) +* + IF( DIR.EQ.0 ) THEN +* +* Sort into decreasing order +* + DO 30 I = START + 1, ENDD + DO 20 J = I, START + 1, -1 + IF( D( J ).GT.D( J-1 ) ) THEN + DMNMX = D( J ) + D( J ) = D( J-1 ) + D( J-1 ) = DMNMX + ELSE + GO TO 30 + END IF + 20 CONTINUE + 30 CONTINUE +* + ELSE +* +* Sort into increasing order +* + DO 50 I = START + 1, ENDD + DO 40 J = I, START + 1, -1 + IF( D( J ).LT.D( J-1 ) ) THEN + DMNMX = D( J ) + D( J ) = D( J-1 ) + D( J-1 ) = DMNMX + ELSE + GO TO 50 + END IF + 40 CONTINUE + 50 CONTINUE +* + END IF +* + ELSE IF( ENDD-START.GT.SELECT ) THEN +* +* Partition D( START:ENDD ) and stack parts, largest one first +* +* Choose partition entry as median of 3 +* + D1 = D( START ) + D2 = D( ENDD ) + I = ( START+ENDD ) / 2 + D3 = D( I ) + IF( D1.LT.D2 ) THEN + IF( D3.LT.D1 ) THEN + DMNMX = D1 + ELSE IF( D3.LT.D2 ) THEN + DMNMX = D3 + ELSE + DMNMX = D2 + END IF + ELSE + IF( D3.LT.D2 ) THEN + DMNMX = D2 + ELSE IF( D3.LT.D1 ) THEN + DMNMX = D3 + ELSE + DMNMX = D1 + END IF + END IF +* + IF( DIR.EQ.0 ) THEN +* +* Sort into decreasing order +* + I = START - 1 + J = ENDD + 1 + 60 CONTINUE + 70 CONTINUE + J = J - 1 + IF( D( J ).LT.DMNMX ) + $ GO TO 70 + 80 CONTINUE + I = I + 1 + IF( D( I ).GT.DMNMX ) + $ GO TO 80 + IF( I.LT.J ) THEN + TMP = D( I ) + D( I ) = D( J ) + D( J ) = TMP + GO TO 60 + END IF + IF( J-START.GT.ENDD-J-1 ) THEN + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = START + STACK( 2, STKPNT ) = J + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = J + 1 + STACK( 2, STKPNT ) = ENDD + ELSE + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = J + 1 + STACK( 2, STKPNT ) = ENDD + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = START + STACK( 2, STKPNT ) = J + END IF + ELSE +* +* Sort into increasing order +* + I = START - 1 + J = ENDD + 1 + 90 CONTINUE + 100 CONTINUE + J = J - 1 + IF( D( J ).GT.DMNMX ) + $ GO TO 100 + 110 CONTINUE + I = I + 1 + IF( D( I ).LT.DMNMX ) + $ GO TO 110 + IF( I.LT.J ) THEN + TMP = D( I ) + D( I ) = D( J ) + D( J ) = TMP + GO TO 90 + END IF + IF( J-START.GT.ENDD-J-1 ) THEN + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = START + STACK( 2, STKPNT ) = J + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = J + 1 + STACK( 2, STKPNT ) = ENDD + ELSE + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = J + 1 + STACK( 2, STKPNT ) = ENDD + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = START + STACK( 2, STKPNT ) = J + END IF + END IF + END IF + IF( STKPNT.GT.0 ) + $ GO TO 10 + RETURN +* +* End of DLASRT +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlasrt} (let* ((select 20)) (declare (type (fixnum 20 20) select)) @@ -67655,44 +94644,101 @@ SYNOPSIS DOUBLE PRECISION X( * ) -PURPOSE - DLASSQ returns the values scl and smsq such that + Purpose + ======= - where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is - assumed to be non-negative and scl returns the value + DLASSQ returns the values scl and smsq such that - scl = max( scale, abs( x( i ) ) ). + ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, - scale and sumsq must be supplied in SCALE and SUMSQ and - scl and smsq are overwritten on SCALE and SUMSQ respectively. + where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is + assumed to be non-negative and scl returns the value - The routine makes only one pass through the vector x. + scl = max( scale, abs( x( i ) ) ). + scale and sumsq must be supplied in SCALE and SUMSQ and + scl and smsq are overwritten on SCALE and SUMSQ respectively. -ARGUMENTS - N (input) INTEGER - The number of elements to be used from the vector X. + The routine makes only one pass through the vector x. + + Arguments + ========= - X (input) DOUBLE PRECISION array, dimension (N) - The vector for which a scaled sum of squares is computed. x( i - ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. + N (input) INTEGER + The number of elements to be used from the vector X. - INCX (input) INTEGER - The increment between successive values of the vector X. INCX - > 0. + X (input) DOUBLE PRECISION array, dimension (N) + The vector for which a scaled sum of squares is computed. + x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. - SCALE (input/output) DOUBLE PRECISION - On entry, the value scale in the equation above. On exit, - SCALE is overwritten with scl , the scaling factor for the sum - of squares. + INCX (input) INTEGER + The increment between successive values of the vector X. + INCX > 0. - SUMSQ (input/output) DOUBLE PRECISION - On entry, the value sumsq in the equation above. On exit, - SUMSQ is overwritten with smsq , the basic sum of squares from - which scl has been factored out. + SCALE (input/output) DOUBLE PRECISION + On entry, the value scale in the equation above. + On exit, SCALE is overwritten with scl , the scaling factor + for the sum of squares. + + SUMSQ (input/output) DOUBLE PRECISION + On entry, the value sumsq in the equation above. + On exit, SUMSQ is overwritten with smsq , the basic sum of + squares from which scl has been factored out. \end{chunk} +\begin{verbatim} + SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) +* +* -- 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 INCX, N + DOUBLE PRECISION SCALE, SUMSQ +* .. +* .. Array Arguments .. + DOUBLE PRECISION X( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER IX + DOUBLE PRECISION ABSXI +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* + IF( N.GT.0 ) THEN + DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX + IF( X( IX ).NE.ZERO ) THEN + ABSXI = ABS( X( IX ) ) + IF( SCALE.LT.ABSXI ) THEN + SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 + SCALE = ABSXI + ELSE + SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 + END IF + END IF + 10 CONTINUE + END IF + RETURN +* +* End of DLASSQ +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlassq} (let* ((zero 0.0)) (declare (type (double-float 0.0 0.0) zero)) @@ -67763,64 +94809,262 @@ SYNOPSIS DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN -PURPOSE - DLASV2 computes the singular value decomposition of a 2-by-2 triangular - matrix - [ F G ] - [ 0 H ]. On return, abs(SSMAX) is the larger singular value, - abs(SSMIN) is the smaller singular value, and (CSL,SNL) and (CSR,SNR) - are the left and right singular vectors for abs(SSMAX), giving the - decomposition + Purpose + ======= - [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] - [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. + DLASV2 computes the singular value decomposition of a 2-by-2 + triangular matrix + [ F G ] + [ 0 H ]. + On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the + smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and + right singular vectors for abs(SSMAX), giving the decomposition + [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] + [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. -ARGUMENTS - F (input) DOUBLE PRECISION - The (1,1) element of the 2-by-2 matrix. + Arguments + ========= - G (input) DOUBLE PRECISION - The (1,2) element of the 2-by-2 matrix. + F (input) DOUBLE PRECISION + The (1,1) element of the 2-by-2 matrix. - H (input) DOUBLE PRECISION - The (2,2) element of the 2-by-2 matrix. + G (input) DOUBLE PRECISION + The (1,2) element of the 2-by-2 matrix. - SSMIN (output) DOUBLE PRECISION - abs(SSMIN) is the smaller singular value. + H (input) DOUBLE PRECISION + The (2,2) element of the 2-by-2 matrix. - SSMAX (output) DOUBLE PRECISION - abs(SSMAX) is the larger singular value. + SSMIN (output) DOUBLE PRECISION + abs(SSMIN) is the smaller singular value. - SNL (output) DOUBLE PRECISION - CSL (output) DOUBLE PRECISION The vector (CSL, SNL) is a - unit left singular vector for the singular value abs(SSMAX). + SSMAX (output) DOUBLE PRECISION + abs(SSMAX) is the larger singular value. - SNR (output) DOUBLE PRECISION - CSR (output) DOUBLE PRECISION The vector (CSR, SNR) is a - unit right singular vector for the singular value abs(SSMAX). + SNL (output) DOUBLE PRECISION + CSL (output) DOUBLE PRECISION + The vector (CSL, SNL) is a unit left singular vector for the + singular value abs(SSMAX). -FURTHER DETAILS - Any input parameter may be aliased with any output parameter. + SNR (output) DOUBLE PRECISION + CSR (output) DOUBLE PRECISION + The vector (CSR, SNR) is a unit right singular vector for the + singular value abs(SSMAX). - Barring over/underflow and assuming a guard digit in subtraction, all - output quantities are correct to within a few units in the last place - (ulps). + Further Details + =============== - In IEEE arithmetic, the code works correctly if one matrix element is - infinite. + Any input parameter may be aliased with any output parameter. - Overflow will not occur unless the largest singular value itself over- - flows or is within a few ulps of overflow. (On machines with partial - overflow, like the Cray, overflow may occur if the largest singular - value is within a factor of 2 of overflow.) + Barring over/underflow and assuming a guard digit in subtraction, all + output quantities are correct to within a few units in the last + place (ulps). - Underflow is harmless if underflow is gradual. Otherwise, results may - correspond to a matrix modified by perturbations of size near the - underflow threshold. + In IEEE arithmetic, the code works correctly if one matrix element is + infinite. + + Overflow will not occur unless the largest singular value itself + overflows or is within a few ulps of overflow. (On machines with + partial overflow, like the Cray, overflow may occur if the largest + singular value is within a factor of 2 of overflow.) + + Underflow is harmless if underflow is gradual. Otherwise, results + may correspond to a matrix modified by perturbations of size near + the underflow threshold. \end{chunk} +\begin{verbatim} + SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) +* +* -- 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 CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = 0.5D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) + DOUBLE PRECISION FOUR + PARAMETER ( FOUR = 4.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL GASMAL, SWAP + INTEGER PMAX + DOUBLE PRECISION A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M, + $ MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SIGN, SQRT +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Executable Statements .. +* + FT = F + FA = ABS( FT ) + HT = H + HA = ABS( H ) +* +* PMAX points to the maximum absolute element of matrix +* PMAX = 1 if F largest in absolute values +* PMAX = 2 if G largest in absolute values +* PMAX = 3 if H largest in absolute values +* + PMAX = 1 + SWAP = ( HA.GT.FA ) + IF( SWAP ) THEN + PMAX = 3 + TEMP = FT + FT = HT + HT = TEMP + TEMP = FA + FA = HA + HA = TEMP +* +* Now FA .ge. HA +* + END IF + GT = G + GA = ABS( GT ) + IF( GA.EQ.ZERO ) THEN +* +* Diagonal matrix +* + SSMIN = HA + SSMAX = FA + CLT = ONE + CRT = ONE + SLT = ZERO + SRT = ZERO + ELSE + GASMAL = .TRUE. + IF( GA.GT.FA ) THEN + PMAX = 2 + IF( ( FA / GA ).LT.DLAMCH( 'EPS' ) ) THEN +* +* Case of very large GA +* + GASMAL = .FALSE. + SSMAX = GA + IF( HA.GT.ONE ) THEN + SSMIN = FA / ( GA / HA ) + ELSE + SSMIN = ( FA / GA )*HA + END IF + CLT = ONE + SLT = HT / GT + SRT = ONE + CRT = FT / GT + END IF + END IF + IF( GASMAL ) THEN +* +* Normal case +* + D = FA - HA + IF( D.EQ.FA ) THEN +* +* Copes with infinite F or H +* + L = ONE + ELSE + L = D / FA + END IF +* +* Note that 0 .le. L .le. 1 +* + M = GT / FT +* +* Note that abs(M) .le. 1/macheps +* + T = TWO - L +* +* Note that T .ge. 1 +* + MM = M*M + TT = T*T + S = SQRT( TT+MM ) +* +* Note that 1 .le. S .le. 1 + 1/macheps +* + IF( L.EQ.ZERO ) THEN + R = ABS( M ) + ELSE + R = SQRT( L*L+MM ) + END IF +* +* Note that 0 .le. R .le. 1 + 1/macheps +* + A = HALF*( S+R ) +* +* Note that 1 .le. A .le. 1 + abs(M) +* + SSMIN = HA / A + SSMAX = FA*A + IF( MM.EQ.ZERO ) THEN +* +* Note that M is very tiny +* + IF( L.EQ.ZERO ) THEN + T = SIGN( TWO, FT )*SIGN( ONE, GT ) + ELSE + T = GT / SIGN( D, FT ) + M / T + END IF + ELSE + T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A ) + END IF + L = SQRT( T*T+FOUR ) + CRT = TWO / L + SRT = T / L + CLT = ( CRT+SRT*M ) / A + SLT = ( HT / FT )*SRT / A + END IF + END IF + IF( SWAP ) THEN + CSL = SRT + SNL = CRT + CSR = SLT + SNR = CLT + ELSE + CSL = CLT + SNL = SLT + CSR = CRT + SNR = SRT + END IF +* +* Correct signs of SSMAX and SSMIN +* + IF( PMAX.EQ.1 ) + $ TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F ) + IF( PMAX.EQ.2 ) + $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G ) + IF( PMAX.EQ.3 ) + $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H ) + SSMAX = SIGN( SSMAX, TSIGN ) + SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) ) + RETURN +* +* End of DLASV2 +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlasv2} (let* ((zero 0.0) (half 0.5) (one 1.0) (two 2.0) (four 4.0)) (declare (type (double-float 0.0 0.0) zero) @@ -67988,41 +95232,132 @@ SYNOPSIS DOUBLE PRECISION A( LDA, * ) -PURPOSE - DLASWP performs a series of row interchanges on the matrix A. One row - interchange is initiated for each of rows K1 through K2 of A. + Purpose + ======= + DLASWP performs a series of row interchanges on the matrix A. + One row interchange is initiated for each of rows K1 through K2 of A. -ARGUMENTS - N (input) INTEGER - The number of columns of the matrix A. + Arguments + ========= - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the matrix of column dimension N to which the row - interchanges will be applied. On exit, the permuted matrix. + N (input) INTEGER + The number of columns of the matrix A. - LDA (input) INTEGER - The leading dimension of the array A. + A (input/output) DOUBLE PRECISION array, dimension (LDA,N) + On entry, the matrix of column dimension N to which the row + interchanges will be applied. + On exit, the permuted matrix. + + LDA (input) INTEGER + The leading dimension of the array A. + + K1 (input) INTEGER + The first element of IPIV for which a row interchange will + be done. + + K2 (input) INTEGER + The last element of IPIV for which a row interchange will + be done. - K1 (input) INTEGER - The first element of IPIV for which a row interchange will be - done. + IPIV (input) INTEGER array, dimension (M*abs(INCX)) + The vector of pivot indices. Only the elements in positions + K1 through K2 of IPIV are accessed. + IPIV(K) = L implies rows K and L are to be interchanged. - K2 (input) INTEGER - The last element of IPIV for which a row interchange will be - done. + INCX (input) INTEGER + The increment between successive values of IPIV. If IPIV + is negative, the pivots are applied in reverse order. - IPIV (input) INTEGER array, dimension (K2*abs(INCX)) - The vector of pivot indices. Only the elements in positions K1 - through K2 of IPIV are accessed. IPIV(K) = L implies rows K - and L are to be interchanged. + Further Details + =============== - INCX (input) INTEGER - The increment between successive values of IPIV. If IPIV is - negative, the pivots are applied in reverse order. + Modified by + R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA \end{chunk} +\begin{verbatim} + SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) +* +* -- 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 INCX, K1, K2, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 + DOUBLE PRECISION TEMP +* .. +* .. Executable Statements .. +* +* Interchange row I with row IPIV(I) for each of rows K1 through K2. +* + IF( INCX.GT.0 ) THEN + IX0 = K1 + I1 = K1 + I2 = K2 + INC = 1 + ELSE IF( INCX.LT.0 ) THEN + IX0 = 1 + ( 1-K2 )*INCX + I1 = K2 + I2 = K1 + INC = -1 + ELSE + RETURN + END IF +* + N32 = ( N / 32 )*32 + IF( N32.NE.0 ) THEN + DO 30 J = 1, N32, 32 + IX = IX0 + DO 20 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 10 K = J, J + 31 + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 10 CONTINUE + END IF + IX = IX + INCX + 20 CONTINUE + 30 CONTINUE + END IF + IF( N32.NE.N ) THEN + N32 = N32 + 1 + IX = IX0 + DO 50 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 40 K = N32, N + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 40 CONTINUE + END IF + IX = IX + INCX + 50 CONTINUE + END IF +* + RETURN +* +* End of DLASWP +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlaswp} (defun dlaswp (n a lda k1 k2 ipiv incx) (declare (type (simple-array fixnum (*)) ipiv) @@ -68168,74 +95503,394 @@ SYNOPSIS DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), X( LDX, * ) -PURPOSE - DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in + Purpose + ======= - where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or - -1. op(T) = T or T', where T' denotes the transpose of T. + DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in + op(TL)*X + ISGN*X*op(TR) = SCALE*B, -ARGUMENTS - LTRANL (input) LOGICAL - On entry, LTRANL specifies the op(TL): = .FALSE., op(TL) = TL, - = .TRUE., op(TL) = TL'. + where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or + -1. op(T) = T or T', where T' denotes the transpose of T. - LTRANR (input) LOGICAL - On entry, LTRANR specifies the op(TR): = .FALSE., op(TR) = TR, - = .TRUE., op(TR) = TR'. + Arguments + ========= - ISGN (input) INTEGER - On entry, ISGN specifies the sign of the equation as described - before. ISGN may only be 1 or -1. + LTRANL (input) LOGICAL + On entry, LTRANL specifies the op(TL): + = .FALSE., op(TL) = TL, + = .TRUE., op(TL) = TL'. - N1 (input) INTEGER - On entry, N1 specifies the order of matrix TL. N1 may only be - 0, 1 or 2. + LTRANR (input) LOGICAL + On entry, LTRANR specifies the op(TR): + = .FALSE., op(TR) = TR, + = .TRUE., op(TR) = TR'. - N2 (input) INTEGER - On entry, N2 specifies the order of matrix TR. N2 may only be - 0, 1 or 2. + ISGN (input) INTEGER + On entry, ISGN specifies the sign of the equation + as described before. ISGN may only be 1 or -1. - TL (input) DOUBLE PRECISION array, dimension (LDTL,2) - On entry, TL contains an N1 by N1 matrix. + N1 (input) INTEGER + On entry, N1 specifies the order of matrix TL. + N1 may only be 0, 1 or 2. - LDTL (input) INTEGER - The leading dimension of the matrix TL. LDTL >= max(1,N1). + N2 (input) INTEGER + On entry, N2 specifies the order of matrix TR. + N2 may only be 0, 1 or 2. - TR (input) DOUBLE PRECISION array, dimension (LDTR,2) - On entry, TR contains an N2 by N2 matrix. + TL (input) DOUBLE PRECISION array, dimension (LDTL,2) + On entry, TL contains an N1 by N1 matrix. - LDTR (input) INTEGER - The leading dimension of the matrix TR. LDTR >= max(1,N2). + LDTL (input) INTEGER + The leading dimension of the matrix TL. LDTL >= max(1,N1). - B (input) DOUBLE PRECISION array, dimension (LDB,2) - On entry, the N1 by N2 matrix B contains the right-hand side of - the equation. + TR (input) DOUBLE PRECISION array, dimension (LDTR,2) + On entry, TR contains an N2 by N2 matrix. - LDB (input) INTEGER - The leading dimension of the matrix B. LDB >= max(1,N1). + LDTR (input) INTEGER + The leading dimension of the matrix TR. LDTR >= max(1,N2). - SCALE (output) DOUBLE PRECISION - On exit, SCALE contains the scale factor. SCALE is chosen less - than or equal to 1 to prevent the solution overflowing. + B (input) DOUBLE PRECISION array, dimension (LDB,2) + On entry, the N1 by N2 matrix B contains the right-hand + side of the equation. - X (output) DOUBLE PRECISION array, dimension (LDX,2) - On exit, X contains the N1 by N2 solution. + LDB (input) INTEGER + The leading dimension of the matrix B. LDB >= max(1,N1). - LDX (input) INTEGER - The leading dimension of the matrix X. LDX >= max(1,N1). + SCALE (output) DOUBLE PRECISION + On exit, SCALE contains the scale factor. SCALE is chosen + less than or equal to 1 to prevent the solution overflowing. - XNORM (output) DOUBLE PRECISION - On exit, XNORM is the infinity-norm of the solution. + X (output) DOUBLE PRECISION array, dimension (LDX,2) + On exit, X contains the N1 by N2 solution. - INFO (output) INTEGER - On exit, INFO is set to 0: successful exit. - 1: TL and TR have too close eigenvalues, so TL or TR is per- - turbed to get a nonsingular equation. NOTE: In the interests - of speed, this routine does not check the inputs for errors. + LDX (input) INTEGER + The leading dimension of the matrix X. LDX >= max(1,N1). + + XNORM (output) DOUBLE PRECISION + On exit, XNORM is the infinity-norm of the solution. + + INFO (output) INTEGER + On exit, INFO is set to + 0: successful exit. + 1: TL and TR have too close eigenvalues, so TL or + TR is perturbed to get a nonsingular equation. + NOTE: In the interests of speed, this routine does not + check the inputs for errors. \end{chunk} +\begin{verbatim} + SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, + $ LDTR, B, LDB, SCALE, X, LDX, 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 LTRANL, LTRANR + INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 + DOUBLE PRECISION SCALE, XNORM +* .. +* .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), + $ X( LDX, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION TWO, HALF, EIGHT + PARAMETER ( TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL BSWAP, XSWAP + INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K + DOUBLE PRECISION BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1, + $ TEMP, U11, U12, U22, XMAX +* .. +* .. Local Arrays .. + LOGICAL BSWPIV( 4 ), XSWPIV( 4 ) + INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ), + $ LOCU22( 4 ) + DOUBLE PRECISION BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 ) +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL IDAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Data statements .. + DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / , + $ LOCU22 / 4, 3, 2, 1 / + DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. / + DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. / +* .. +* .. Executable Statements .. +* +* Do not check the input parameters for errors +* + INFO = 0 +* +* Quick return if possible +* + IF( N1.EQ.0 .OR. N2.EQ.0 ) + $ RETURN +* +* Set constants to control overflow +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + SGN = ISGN +* + K = N1 + N1 + N2 - 2 + GO TO ( 10, 20, 30, 50 )K +* +* 1 by 1: TL11*X + SGN*X*TR11 = B11 +* + 10 CONTINUE + TAU1 = TL( 1, 1 ) + SGN*TR( 1, 1 ) + BET = ABS( TAU1 ) + IF( BET.LE.SMLNUM ) THEN + TAU1 = SMLNUM + BET = SMLNUM + INFO = 1 + END IF +* + SCALE = ONE + GAM = ABS( B( 1, 1 ) ) + IF( SMLNUM*GAM.GT.BET ) + $ SCALE = ONE / GAM +* + X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 + XNORM = ABS( X( 1, 1 ) ) + RETURN +* +* 1 by 2: +* TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12] +* [TR21 TR22] +* + 20 CONTINUE +* + SMIN = MAX( EPS*MAX( ABS( TL( 1, 1 ) ), ABS( TR( 1, 1 ) ), + $ ABS( TR( 1, 2 ) ), ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ), + $ SMLNUM ) + TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) + TMP( 4 ) = TL( 1, 1 ) + SGN*TR( 2, 2 ) + IF( LTRANR ) THEN + TMP( 2 ) = SGN*TR( 2, 1 ) + TMP( 3 ) = SGN*TR( 1, 2 ) + ELSE + TMP( 2 ) = SGN*TR( 1, 2 ) + TMP( 3 ) = SGN*TR( 2, 1 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 1, 2 ) + GO TO 40 +* +* 2 by 1: +* op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11] +* [TL21 TL22] [X21] [X21] [B21] +* + 30 CONTINUE + SMIN = MAX( EPS*MAX( ABS( TR( 1, 1 ) ), ABS( TL( 1, 1 ) ), + $ ABS( TL( 1, 2 ) ), ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ), + $ SMLNUM ) + TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) + TMP( 4 ) = TL( 2, 2 ) + SGN*TR( 1, 1 ) + IF( LTRANL ) THEN + TMP( 2 ) = TL( 1, 2 ) + TMP( 3 ) = TL( 2, 1 ) + ELSE + TMP( 2 ) = TL( 2, 1 ) + TMP( 3 ) = TL( 1, 2 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 2, 1 ) + 40 CONTINUE +* +* Solve 2 by 2 system using complete pivoting. +* Set pivots less than SMIN to SMIN. +* + IPIV = IDAMAX( 4, TMP, 1 ) + U11 = TMP( IPIV ) + IF( ABS( U11 ).LE.SMIN ) THEN + INFO = 1 + U11 = SMIN + END IF + U12 = TMP( LOCU12( IPIV ) ) + L21 = TMP( LOCL21( IPIV ) ) / U11 + U22 = TMP( LOCU22( IPIV ) ) - U12*L21 + XSWAP = XSWPIV( IPIV ) + BSWAP = BSWPIV( IPIV ) + IF( ABS( U22 ).LE.SMIN ) THEN + INFO = 1 + U22 = SMIN + END IF + IF( BSWAP ) THEN + TEMP = BTMP( 2 ) + BTMP( 2 ) = BTMP( 1 ) - L21*TEMP + BTMP( 1 ) = TEMP + ELSE + BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 ) + END IF + SCALE = ONE + IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR. + $ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN + SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) ) + BTMP( 1 ) = BTMP( 1 )*SCALE + BTMP( 2 ) = BTMP( 2 )*SCALE + END IF + X2( 2 ) = BTMP( 2 ) / U22 + X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 ) + IF( XSWAP ) THEN + TEMP = X2( 2 ) + X2( 2 ) = X2( 1 ) + X2( 1 ) = TEMP + END IF + X( 1, 1 ) = X2( 1 ) + IF( N1.EQ.1 ) THEN + X( 1, 2 ) = X2( 2 ) + XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) ) + ELSE + X( 2, 1 ) = X2( 2 ) + XNORM = MAX( ABS( X( 1, 1 ) ), ABS( X( 2, 1 ) ) ) + END IF + RETURN +* +* 2 by 2: +* op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12] +* [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22] +* +* Solve equivalent 4 by 4 system using complete pivoting. +* Set pivots less than SMIN to SMIN. +* + 50 CONTINUE + SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), + $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) + SMIN = MAX( SMIN, ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), + $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) + SMIN = MAX( EPS*SMIN, SMLNUM ) + BTMP( 1 ) = ZERO + CALL DCOPY( 16, BTMP, 0, T16, 1 ) + T16( 1, 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) + T16( 2, 2 ) = TL( 2, 2 ) + SGN*TR( 1, 1 ) + T16( 3, 3 ) = TL( 1, 1 ) + SGN*TR( 2, 2 ) + T16( 4, 4 ) = TL( 2, 2 ) + SGN*TR( 2, 2 ) + IF( LTRANL ) THEN + T16( 1, 2 ) = TL( 2, 1 ) + T16( 2, 1 ) = TL( 1, 2 ) + T16( 3, 4 ) = TL( 2, 1 ) + T16( 4, 3 ) = TL( 1, 2 ) + ELSE + T16( 1, 2 ) = TL( 1, 2 ) + T16( 2, 1 ) = TL( 2, 1 ) + T16( 3, 4 ) = TL( 1, 2 ) + T16( 4, 3 ) = TL( 2, 1 ) + END IF + IF( LTRANR ) THEN + T16( 1, 3 ) = SGN*TR( 1, 2 ) + T16( 2, 4 ) = SGN*TR( 1, 2 ) + T16( 3, 1 ) = SGN*TR( 2, 1 ) + T16( 4, 2 ) = SGN*TR( 2, 1 ) + ELSE + T16( 1, 3 ) = SGN*TR( 2, 1 ) + T16( 2, 4 ) = SGN*TR( 2, 1 ) + T16( 3, 1 ) = SGN*TR( 1, 2 ) + T16( 4, 2 ) = SGN*TR( 1, 2 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 2, 1 ) + BTMP( 3 ) = B( 1, 2 ) + BTMP( 4 ) = B( 2, 2 ) +* +* Perform elimination +* + DO 100 I = 1, 3 + XMAX = ZERO + DO 70 IP = I, 4 + DO 60 JP = I, 4 + IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN + XMAX = ABS( T16( IP, JP ) ) + IPSV = IP + JPSV = JP + END IF + 60 CONTINUE + 70 CONTINUE + IF( IPSV.NE.I ) THEN + CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 ) + TEMP = BTMP( I ) + BTMP( I ) = BTMP( IPSV ) + BTMP( IPSV ) = TEMP + END IF + IF( JPSV.NE.I ) + $ CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 ) + JPIV( I ) = JPSV + IF( ABS( T16( I, I ) ).LT.SMIN ) THEN + INFO = 1 + T16( I, I ) = SMIN + END IF + DO 90 J = I + 1, 4 + T16( J, I ) = T16( J, I ) / T16( I, I ) + BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) + DO 80 K = I + 1, 4 + T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + IF( ABS( T16( 4, 4 ) ).LT.SMIN ) + $ T16( 4, 4 ) = SMIN + SCALE = ONE + IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN + SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ), + $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), ABS( BTMP( 4 ) ) ) + BTMP( 1 ) = BTMP( 1 )*SCALE + BTMP( 2 ) = BTMP( 2 )*SCALE + BTMP( 3 ) = BTMP( 3 )*SCALE + BTMP( 4 ) = BTMP( 4 )*SCALE + END IF + DO 120 I = 1, 4 + K = 5 - I + TEMP = ONE / T16( K, K ) + TMP( K ) = BTMP( K )*TEMP + DO 110 J = K + 1, 4 + TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) + 110 CONTINUE + 120 CONTINUE + DO 130 I = 1, 3 + IF( JPIV( 4-I ).NE.4-I ) THEN + TEMP = TMP( 4-I ) + TMP( 4-I ) = TMP( JPIV( 4-I ) ) + TMP( JPIV( 4-I ) ) = TEMP + END IF + 130 CONTINUE + X( 1, 1 ) = TMP( 1 ) + X( 2, 1 ) = TMP( 2 ) + X( 1, 2 ) = TMP( 3 ) + X( 2, 2 ) = TMP( 4 ) + XNORM = MAX( ABS( TMP( 1 ) )+ABS( TMP( 3 ) ), + $ ABS( TMP( 2 ) )+ABS( TMP( 4 ) ) ) + RETURN +* +* End of DLASY2 +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dlasy2} (let* ((zero 0.0) (one 1.0) (two 2.0) (half 0.5) (eight 8.0)) (declare (type (double-float 0.0 0.0) zero) @@ -68959,48 +96614,142 @@ SYNOPSIS DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -PURPOSE - DORG2R generates an m by n real matrix Q with orthonormal columns, - which is defined as the first n columns of a product of k elementary - reflectors of order m + Purpose + ======= - Q = H(1) H(2) . . . H(k) + DORG2R generates an m by n real matrix Q with orthonormal columns, + which is defined as the first n columns of a product of k elementary + reflectors of order m - as returned by DGEQRF. + Q = H(1) H(2) . . . H(k) + as returned by DGEQRF. -ARGUMENTS - M (input) INTEGER - The number of rows of the matrix Q. M >= 0. + Arguments + ========= - N (input) INTEGER - The number of columns of the matrix Q. M >= N >= 0. + M (input) INTEGER + The number of rows of the matrix Q. M >= 0. - K (input) INTEGER - The number of elementary reflectors whose product defines the - matrix Q. N >= K >= 0. + N (input) INTEGER + The number of columns of the matrix Q. M >= N >= 0. - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the i-th column must contain the vector which defines - the elementary reflector H(i), for i = 1,2,...,k, as returned - by DGEQRF in the first k columns of its array argument A. On - exit, the m-by-n matrix Q. + K (input) INTEGER + The number of elementary reflectors whose product defines the + matrix Q. N >= K >= 0. - LDA (input) INTEGER - The first dimension of the array A. LDA >= max(1,M). + A (input/output) DOUBLE PRECISION array, dimension (LDA,N) + On entry, the i-th column must contain the vector which + defines the elementary reflector H(i), for i = 1,2,...,k, as + returned by DGEQRF in the first k columns of its array + argument A. + On exit, the m-by-n matrix Q. - TAU (input) DOUBLE PRECISION array, dimension (K) - TAU(i) must contain the scalar factor of the elementary reflec- - tor H(i), as returned by DGEQRF. + LDA (input) INTEGER + The first dimension of the array A. LDA >= max(1,M). - WORK (workspace) DOUBLE PRECISION array, dimension (N) + TAU (input) DOUBLE PRECISION array, dimension (K) + TAU(i) must contain the scalar factor of the elementary + reflector H(i), as returned by DGEQRF. - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument has an illegal value + WORK (workspace) DOUBLE PRECISION array, dimension (N) + + INFO (output) INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument has an illegal value \end{chunk} +\begin{verbatim} + SUBROUTINE DORG2R( M, N, K, 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, K, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, L +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORG2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* +* Initialise columns k+1:n to columns of the unit matrix +* + DO 20 J = K + 1, N + DO 10 L = 1, M + A( L, J ) = ZERO + 10 CONTINUE + A( J, J ) = ONE + 20 CONTINUE +* + DO 40 I = K, 1, -1 +* +* Apply H(i) to A(i:m,i:n) from the left +* + IF( I.LT.N ) THEN + A( I, I ) = ONE + CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) + END IF + IF( I.LT.M ) + $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) + A( I, I ) = ONE - TAU( I ) +* +* Set A(1:i-1,i) to zero +* + DO 30 L = 1, I - 1 + A( L, I ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of DORG2R +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dorg2r} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -69115,80 +96864,256 @@ SYNOPSIS DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -PURPOSE - DORGBR generates one of the real orthogonal matrices Q or P**T deter- - mined by DGEBRD when reducing a real matrix A to bidiagonal form: A = Q - * B * P**T. Q and P**T are defined as products of elementary reflec- - tors H(i) or G(i) respectively. - - If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q is of - order M: - if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n - columns of Q, where m >= n >= k; - if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an M-by-M - matrix. - - If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T is - of order N: - if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m - rows of P**T, where n >= m >= k; - if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as an - N-by-N matrix. + Purpose + ======= + + DORGBR generates one of the real orthogonal matrices Q or P**T + determined by DGEBRD when reducing a real matrix A to bidiagonal + form: A = Q * B * P**T. Q and P**T are defined as products of + elementary reflectors H(i) or G(i) respectively. + + If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q + is of order M: + if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n + columns of Q, where m >= n >= k; + if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an + M-by-M matrix. + + If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T + is of order N: + if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m + rows of P**T, where n >= m >= k; + if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as + an N-by-N matrix. + + Arguments + ========= + + VECT (input) CHARACTER*1 + Specifies whether the matrix Q or the matrix P**T is + required, as defined in the transformation applied by DGEBRD: + = 'Q': generate Q; + = 'P': generate P**T. + + M (input) INTEGER + The number of rows of the matrix Q or P**T to be returned. + M >= 0. + + N (input) INTEGER + The number of columns of the matrix Q or P**T to be returned. + N >= 0. + If VECT = 'Q', M >= N >= min(M,K); + if VECT = 'P', N >= M >= min(N,K). + + K (input) INTEGER + If VECT = 'Q', the number of columns in the original M-by-K + matrix reduced by DGEBRD. + If VECT = 'P', the number of rows in the original K-by-N + matrix reduced by DGEBRD. + K >= 0. + + A (input/output) DOUBLE PRECISION array, dimension (LDA,N) + On entry, the vectors which define the elementary reflectors, + as returned by DGEBRD. + On exit, the M-by-N matrix Q or P**T. + + LDA (input) INTEGER + The leading dimension of the array A. LDA >= max(1,M). + + TAU (input) DOUBLE PRECISION array, dimension + (min(M,K)) if VECT = 'Q' + (min(N,K)) if VECT = 'P' + TAU(i) must contain the scalar factor of the elementary + reflector H(i) or G(i), which determines Q or P**T, as + returned by DGEBRD in its array argument TAUQ or TAUP. + + 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,min(M,N)). + For optimum performance LWORK >= min(M,N)*NB, where NB + is the optimal blocksize. + + If LWORK = -1, then a workspace query is assumed; the routine + only calculates the optimal size of the WORK array, returns + this value as the first entry of the WORK array, and no error + message related to LWORK is issued by XERBLA. + + INFO (output) INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value +\end{chunk} -ARGUMENTS - VECT (input) CHARACTER*1 - Specifies whether the matrix Q or the matrix P**T is required, - as defined in the transformation applied by DGEBRD: - = 'Q': generate Q; - = 'P': generate P**T. - - M (input) INTEGER - The number of rows of the matrix Q or P**T to be returned. M - >= 0. - - N (input) INTEGER - The number of columns of the matrix Q or P**T to be returned. - N >= 0. If VECT = 'Q', M >= N >= min(M,K); if VECT = 'P', N >= - M >= min(N,K). - - K (input) INTEGER - If VECT = 'Q', the number of columns in the original M-by-K - matrix reduced by DGEBRD. If VECT = 'P', the number of rows in - the original K-by-N matrix reduced by DGEBRD. K >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the vectors which define the elementary reflectors, - as returned by DGEBRD. On exit, the M-by-N matrix Q or P**T. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). - - TAU (input) DOUBLE PRECISION array, dimension - (min(M,K)) if VECT = 'Q' (min(N,K)) if VECT = 'P' TAU(i) must - contain the scalar factor of the elementary reflector H(i) or - G(i), which determines Q or P**T, as returned by DGEBRD in its - array argument TAUQ or TAUP. - - WORK (workspace/output) DOUBLE PRECISION array, dimension - (MAX(1,LWORK)) - On exit, if INFO = 0, WORK(1) returns the optimal LWORK. - - LWORK (input) INTEGER - The dimension of the array WORK. LWORK >= max(1,min(M,N)). For - optimum performance LWORK >= min(M,N)*NB, where NB is the opti- - mal blocksize. - - If LWORK = -1, then a workspace query is assumed; the routine - only calculates the optimal size of the WORK array, returns - this value as the first entry of the WORK array, and no error - message related to LWORK is issued by XERBLA. - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value +\begin{verbatim} + SUBROUTINE DORGBR( VECT, M, N, K, 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 .. + CHARACTER VECT + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, WANTQ + INTEGER I, IINFO, J, LWKOPT, MN, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DORGLQ, DORGQR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + WANTQ = LSAME( VECT, 'Q' ) + MN = MIN( M, N ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M, + $ K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT. + $ MIN( N, K ) ) ) ) THEN + INFO = -3 + ELSE IF( K.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN + INFO = -9 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( WANTQ ) THEN + NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) + ELSE + NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 ) + END IF + LWKOPT = MAX( 1, MN )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGBR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( WANTQ ) THEN +* +* Form Q, determined by a call to DGEBRD to reduce an m-by-k +* matrix +* + IF( M.GE.K ) THEN +* +* If m >= k, assume m >= n >= k +* + CALL DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) +* + ELSE +* +* If m < k, assume m = n +* +* Shift the vectors which define the elementary reflectors one +* column to the right, and set the first row and column of Q +* to those of the unit matrix +* + DO 20 J = M, 2, -1 + A( 1, J ) = ZERO + DO 10 I = J + 1, M + A( I, J ) = A( I, J-1 ) + 10 CONTINUE + 20 CONTINUE + A( 1, 1 ) = ONE + DO 30 I = 2, M + A( I, 1 ) = ZERO + 30 CONTINUE + IF( M.GT.1 ) THEN +* +* Form Q(2:m,2:m) +* + CALL DORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK, + $ LWORK, IINFO ) + END IF + END IF + ELSE +* +* Form P', determined by a call to DGEBRD to reduce a k-by-n +* matrix +* + IF( K.LT.N ) THEN +* +* If k < n, assume k <= m <= n +* + CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) +* + ELSE +* +* If k >= n, assume m = n +* +* Shift the vectors which define the elementary reflectors one +* row downward, and set the first row and column of P' to +* those of the unit matrix +* + A( 1, 1 ) = ONE + DO 40 I = 2, N + A( I, 1 ) = ZERO + 40 CONTINUE + DO 60 J = 2, N + DO 50 I = J - 1, 2, -1 + A( I, J ) = A( I-1, J ) + 50 CONTINUE + A( 1, J ) = ZERO + 60 CONTINUE + IF( N.GT.1 ) THEN +* +* Form P'(2:n,2:n) +* + CALL DORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, + $ LWORK, IINFO ) + END IF + END IF + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORGBR +* + END -\end{chunk} +\end{verbatim} \begin{chunk}{LAPACK dorgbr} (let* ((zero 0.0) (one 1.0)) @@ -69414,56 +97339,177 @@ SYNOPSIS DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -PURPOSE - DORGHR generates a real orthogonal matrix Q which is defined as the - product of IHI-ILO elementary reflectors of order N, as returned by - DGEHRD: + Purpose + ======= - Q = H(ilo) H(ilo+1) . . . H(ihi-1). + DORGHR generates a real orthogonal matrix Q which is defined as the + product of IHI-ILO elementary reflectors of order N, as returned by + DGEHRD: + Q = H(ilo) H(ilo+1) . . . H(ihi-1). -ARGUMENTS - N (input) INTEGER - The order of the matrix Q. N >= 0. + Arguments + ========= - ILO (input) INTEGER - IHI (input) INTEGER ILO and IHI must have the same values - as in the previous call of DGEHRD. Q is equal to the unit - matrix except in the submatrix Q(ilo+1:ihi,ilo+1:ihi). 1 <= - ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. + N (input) INTEGER + The order of the matrix Q. N >= 0. - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the vectors which define the elementary reflectors, - as returned by DGEHRD. On exit, the N-by-N orthogonal matrix - Q. + ILO (input) INTEGER + IHI (input) INTEGER + ILO and IHI must have the same values as in the previous call + of DGEHRD. Q is equal to the unit matrix except in the + submatrix Q(ilo+1:ihi,ilo+1:ihi). + 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,N). + A (input/output) DOUBLE PRECISION array, dimension (LDA,N) + On entry, the vectors which define the elementary reflectors, + as returned by DGEHRD. + On exit, the N-by-N orthogonal matrix Q. - TAU (input) DOUBLE PRECISION array, dimension (N-1) - TAU(i) must contain the scalar factor of the elementary reflec- - tor H(i), as returned by DGEHRD. + LDA (input) INTEGER + The leading dimension of the array A. LDA >= max(1,N). - WORK (workspace/output) DOUBLE PRECISION array, dimension - (MAX(1,LWORK)) - On exit, if INFO = 0, WORK(1) returns the optimal LWORK. + TAU (input) DOUBLE PRECISION array, dimension (N-1) + TAU(i) must contain the scalar factor of the elementary + reflector H(i), as returned by DGEHRD. - LWORK (input) INTEGER - The dimension of the array WORK. LWORK >= IHI-ILO. For optimum - performance LWORK >= (IHI-ILO)*NB, where NB is the optimal - blocksize. + WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) + On exit, if INFO = 0, WORK(1) returns the optimal LWORK. - 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. + LWORK (input) INTEGER + The dimension of the array WORK. LWORK >= IHI-ILO. + For optimum performance LWORK >= (IHI-ILO)*NB, where NB is + the optimal blocksize. - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value + 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 \end{chunk} +\begin{verbatim} + SUBROUTINE DORGHR( 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 .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IINFO, J, LWKOPT, NB, NH +* .. +* .. External Subroutines .. + EXTERNAL DORGQR, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NH = IHI - ILO + LQUERY = ( LWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + NB = ILAENV( 1, 'DORGQR', ' ', NH, NH, NH, -1 ) + LWKOPT = MAX( 1, NH )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGHR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* Shift the vectors which define the elementary reflectors one +* column to the right, and set the first ilo and the last n-ihi +* rows and columns to those of the unit matrix +* + DO 40 J = IHI, ILO + 1, -1 + DO 10 I = 1, J - 1 + A( I, J ) = ZERO + 10 CONTINUE + DO 20 I = J + 1, IHI + A( I, J ) = A( I, J-1 ) + 20 CONTINUE + DO 30 I = IHI + 1, N + A( I, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + DO 60 J = 1, ILO + DO 50 I = 1, N + A( I, J ) = ZERO + 50 CONTINUE + A( J, J ) = ONE + 60 CONTINUE + DO 80 J = IHI + 1, N + DO 70 I = 1, N + A( I, J ) = ZERO + 70 CONTINUE + A( J, J ) = ONE + 80 CONTINUE +* + IF( NH.GT.0 ) THEN +* +* Generate Q(ilo+1:ihi,ilo+1:ihi) +* + CALL DORGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), + $ WORK, LWORK, IINFO ) + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORGHR +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dorghr} (let* ((zero 0.0) (one 1.0)) (declare (type (double-float 0.0 0.0) zero) @@ -69616,48 +97662,146 @@ SYNOPSIS DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -PURPOSE - DORGL2 generates an m by n real matrix Q with orthonormal rows, which - is defined as the first m rows of a product of k elementary reflectors - of order n + Purpose + ======= - Q = H(k) . . . H(2) H(1) + DORGL2 generates an m by n real matrix Q with orthonormal rows, + which is defined as the first m rows of a product of k elementary + reflectors of order n - as returned by DGELQF. + Q = H(k) . . . H(2) H(1) + as returned by DGELQF. -ARGUMENTS - M (input) INTEGER - The number of rows of the matrix Q. M >= 0. + Arguments + ========= - N (input) INTEGER - The number of columns of the matrix Q. N >= M. + M (input) INTEGER + The number of rows of the matrix Q. M >= 0. - K (input) INTEGER - The number of elementary reflectors whose product defines the - matrix Q. M >= K >= 0. + N (input) INTEGER + The number of columns of the matrix Q. N >= M. - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the i-th row must contain the vector which defines - the elementary reflector H(i), for i = 1,2,...,k, as returned - by DGELQF in the first k rows of its array argument A. On - exit, the m-by-n matrix Q. + K (input) INTEGER + The number of elementary reflectors whose product defines the + matrix Q. M >= K >= 0. - LDA (input) INTEGER - The first dimension of the array A. LDA >= max(1,M). + A (input/output) DOUBLE PRECISION array, dimension (LDA,N) + On entry, the i-th row must contain the vector which defines + the elementary reflector H(i), for i = 1,2,...,k, as returned + by DGELQF in the first k rows of its array argument A. + On exit, the m-by-n matrix Q. - TAU (input) DOUBLE PRECISION array, dimension (K) - TAU(i) must contain the scalar factor of the elementary reflec- - tor H(i), as returned by DGELQF. + LDA (input) INTEGER + The first dimension of the array A. LDA >= max(1,M). - WORK (workspace) DOUBLE PRECISION array, dimension (M) + TAU (input) DOUBLE PRECISION array, dimension (K) + TAU(i) must contain the scalar factor of the elementary + reflector H(i), as returned by DGELQF. - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument has an illegal value + WORK (workspace) DOUBLE PRECISION array, dimension (M) + + INFO (output) INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument has an illegal value \end{chunk} +\begin{verbatim} + SUBROUTINE DORGL2( M, N, K, 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 +* June 30, 1999 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, L +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.M ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGL2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.LE.0 ) + $ RETURN +* + IF( K.LT.M ) THEN +* +* Initialise rows k+1:m to rows of the unit matrix +* + DO 20 J = 1, N + DO 10 L = K + 1, M + A( L, J ) = ZERO + 10 CONTINUE + IF( J.GT.K .AND. J.LE.M ) + $ A( J, J ) = ONE + 20 CONTINUE + END IF +* + DO 40 I = K, 1, -1 +* +* Apply H(i) to A(i:m,i:n) from the right +* + IF( I.LT.N ) THEN + IF( I.LT.M ) THEN + A( I, I ) = ONE + CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAU( I ), A( I+1, I ), LDA, WORK ) + END IF + CALL DSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) + END IF + A( I, I ) = ONE - TAU( I ) +* +* Set A(i,1:i-1) to zero +* + DO 30 L = 1, I - 1 + A( I, L ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of DORGL2 +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dorgl2} (let* ((one 1.0) (zero 0.0)) (declare (type (double-float 1.0 1.0) one) @@ -69782,60 +97926,228 @@ SYNOPSIS DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -PURPOSE - DORGLQ generates an M-by-N real matrix Q with orthonormal rows, which - is defined as the first M rows of a product of K elementary reflectors - of order N + Purpose + ======= - Q = H(k) . . . H(2) H(1) + DORGLQ generates an M-by-N real matrix Q with orthonormal rows, + which is defined as the first M rows of a product of K elementary + reflectors of order N - as returned by DGELQF. + Q = H(k) . . . H(2) H(1) + as returned by DGELQF. -ARGUMENTS - M (input) INTEGER - The number of rows of the matrix Q. M >= 0. + Arguments + ========= - N (input) INTEGER - The number of columns of the matrix Q. N >= M. + M (input) INTEGER + The number of rows of the matrix Q. M >= 0. - K (input) INTEGER - The number of elementary reflectors whose product defines the - matrix Q. M >= K >= 0. + N (input) INTEGER + The number of columns of the matrix Q. N >= M. - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the i-th row must contain the vector which defines - the elementary reflector H(i), for i = 1,2,...,k, as returned - by DGELQF in the first k rows of its array argument A. On - exit, the M-by-N matrix Q. + K (input) INTEGER + The number of elementary reflectors whose product defines the + matrix Q. M >= K >= 0. - LDA (input) INTEGER - The first dimension of the array A. LDA >= max(1,M). + A (input/output) DOUBLE PRECISION array, dimension (LDA,N) + On entry, the i-th row must contain the vector which defines + the elementary reflector H(i), for i = 1,2,...,k, as returned + by DGELQF in the first k rows of its array argument A. + On exit, the M-by-N matrix Q. - TAU (input) DOUBLE PRECISION array, dimension (K) - TAU(i) must contain the scalar factor of the elementary reflec- - tor H(i), as returned by DGELQF. + LDA (input) INTEGER + The first dimension of the array A. LDA >= max(1,M). - WORK (workspace/output) DOUBLE PRECISION array, dimension - (MAX(1,LWORK)) - On exit, if INFO = 0, WORK(1) returns the optimal LWORK. + TAU (input) DOUBLE PRECISION array, dimension (K) + TAU(i) must contain the scalar factor of the elementary + reflector H(i), as returned by DGELQF. - LWORK (input) INTEGER - The dimension of the array WORK. LWORK >= max(1,M). For opti- - mum performance LWORK >= M*NB, where NB is the optimal block- - size. + WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) + On exit, if INFO = 0, WORK(1) returns the optimal LWORK. - 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. + LWORK (input) INTEGER + The dimension of the array WORK. LWORK >= max(1,M). + For optimum performance LWORK >= M*NB, where NB is + the optimal blocksize. - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument has an illegal value + 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 has an illegal value \end{chunk} +\begin{verbatim} + SUBROUTINE DORGLQ( M, N, K, 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, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, + $ LWKOPT, NB, NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORGL2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 ) + LWKOPT = MAX( 1, M )*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.M ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGLQ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.LE.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = M + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DORGLQ', ' ', M, N, K, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = M + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORGLQ', ' ', M, N, K, -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code after the last block. +* The first kk rows are handled by the block method. +* + KI = ( ( K-NX-1 ) / NB )*NB + KK = MIN( K, KI+NB ) +* +* Set A(kk+1:m,1:kk) to zero. +* + DO 20 J = 1, KK + DO 10 I = KK + 1, M + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + KK = 0 + END IF +* +* Use unblocked code for the last or only block. +* + IF( KK.LT.M ) + $ CALL DORGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, + $ TAU( KK+1 ), WORK, IINFO ) +* + IF( KK.GT.0 ) THEN +* +* Use blocked code +* + DO 50 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF( I+IB.LE.M ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), + $ LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H' to A(i+ib:m,i:n) from the right +* + CALL DLARFB( 'Right', 'Transpose', 'Forward', 'Rowwise', + $ M-I-IB+1, N-I+1, IB, A( I, I ), LDA, WORK, + $ LDWORK, A( I+IB, I ), LDA, WORK( IB+1 ), + $ LDWORK ) + END IF +* +* Apply H' to columns i:n of current block +* + CALL DORGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* +* Set columns 1:i-1 of current block to zero +* + DO 40 J = 1, I - 1 + DO 30 L = I, I + IB - 1 + A( L, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of DORGLQ +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dorglq} (let* ((zero 0.0)) (declare (type (double-float 0.0 0.0) zero)) @@ -70032,60 +98344,229 @@ SYNOPSIS DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -PURPOSE - DORGQR generates an M-by-N real matrix Q with orthonormal columns, - which is defined as the first N columns of a product of K elementary - reflectors of order M + Purpose + ======= - Q = H(1) H(2) . . . H(k) + DORGQR generates an M-by-N real matrix Q with orthonormal columns, + which is defined as the first N columns of a product of K elementary + reflectors of order M - as returned by DGEQRF. + Q = H(1) H(2) . . . H(k) + as returned by DGEQRF. -ARGUMENTS - M (input) INTEGER - The number of rows of the matrix Q. M >= 0. + Arguments + ========= - N (input) INTEGER - The number of columns of the matrix Q. M >= N >= 0. + M (input) INTEGER + The number of rows of the matrix Q. M >= 0. - K (input) INTEGER - The number of elementary reflectors whose product defines the - matrix Q. N >= K >= 0. + N (input) INTEGER + The number of columns of the matrix Q. M >= N >= 0. - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the i-th column must contain the vector which defines - the elementary reflector H(i), for i = 1,2,...,k, as returned - by DGEQRF in the first k columns of its array argument A. On - exit, the M-by-N matrix Q. + K (input) INTEGER + The number of elementary reflectors whose product defines the + matrix Q. N >= K >= 0. - LDA (input) INTEGER - The first dimension of the array A. LDA >= max(1,M). + A (input/output) DOUBLE PRECISION array, dimension (LDA,N) + On entry, the i-th column must contain the vector which + defines the elementary reflector H(i), for i = 1,2,...,k, as + returned by DGEQRF in the first k columns of its array + argument A. + On exit, the M-by-N matrix Q. - TAU (input) DOUBLE PRECISION array, dimension (K) - TAU(i) must contain the scalar factor of the elementary reflec- - tor H(i), as returned by DGEQRF. + LDA (input) INTEGER + The first dimension of the array A. LDA >= max(1,M). - WORK (workspace/output) DOUBLE PRECISION array, dimension - (MAX(1,LWORK)) - On exit, if INFO = 0, WORK(1) returns the optimal LWORK. + TAU (input) DOUBLE PRECISION array, dimension (K) + TAU(i) must contain the scalar factor of the elementary + reflector H(i), as returned by DGEQRF. - LWORK (input) INTEGER - The dimension of the array WORK. LWORK >= max(1,N). For opti- - mum performance LWORK >= N*NB, where NB is the optimal block- - size. + WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) + On exit, if INFO = 0, WORK(1) returns the optimal LWORK. - 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. + LWORK (input) INTEGER + The dimension of the array WORK. LWORK >= max(1,N). + For optimum performance LWORK >= N*NB, where NB is the + optimal blocksize. - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument has an illegal value + 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 has an illegal value \end{chunk} +\begin{verbatim} + SUBROUTINE DORGQR( M, N, K, 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, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, + $ LWKOPT, NB, NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) + LWKOPT = MAX( 1, N )*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code after the last block. +* The first kk columns are handled by the block method. +* + KI = ( ( K-NX-1 ) / NB )*NB + KK = MIN( K, KI+NB ) +* +* Set A(1:kk,kk+1:n) to zero. +* + DO 20 J = KK + 1, N + DO 10 I = 1, KK + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + KK = 0 + END IF +* +* Use unblocked code for the last or only block. +* + IF( KK.LT.N ) + $ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, + $ TAU( KK+1 ), WORK, IINFO ) +* + IF( KK.GT.0 ) THEN +* +* Use blocked code +* + DO 50 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF( I+IB.LE.N ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, + $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H to A(i:m,i+ib:n) from the left +* + CALL DLARFB( 'Left', 'No transpose', 'Forward', + $ 'Columnwise', M-I+1, N-I-IB+1, IB, + $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), + $ LDA, WORK( IB+1 ), LDWORK ) + END IF +* +* Apply H to rows i:m of current block +* + CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* +* Set rows 1:i-1 of current block to zero +* + DO 40 J = I, I + IB - 1 + DO 30 L = 1, I - 1 + A( L, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of DORGQR +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dorgqr} (let* ((zero 0.0)) (declare (type (double-float 0.0 0.0) zero)) @@ -70288,68 +98769,210 @@ SYNOPSIS DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -PURPOSE - DORM2R overwrites the general real m by n matrix C with + Purpose + ======= - where Q is a real orthogonal matrix defined as the product of k elemen- - tary reflectors + DORM2R overwrites the general real m by n matrix C with - Q = H(1) H(2) . . . H(k) + Q * C if SIDE = 'L' and TRANS = 'N', or - as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n if - SIDE = 'R'. + Q'* C if SIDE = 'L' and TRANS = 'T', or + C * Q if SIDE = 'R' and TRANS = 'N', or -ARGUMENTS - SIDE (input) CHARACTER*1 - = 'L': apply Q or Q' from the Left - = 'R': apply Q or Q' from the Right + C * Q' if SIDE = 'R' and TRANS = 'T', - TRANS (input) CHARACTER*1 - = 'N': apply Q (No transpose) - = 'T': apply Q' (Transpose) + where Q is a real orthogonal matrix defined as the product of k + elementary reflectors - M (input) INTEGER - The number of rows of the matrix C. M >= 0. + Q = H(1) H(2) . . . H(k) - N (input) INTEGER - The number of columns of the matrix C. N >= 0. + as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n + if SIDE = 'R'. - K (input) INTEGER - The number of elementary reflectors whose product defines the - matrix Q. If SIDE = 'L', M >= K >= 0; if SIDE = 'R', N >= K >= - 0. + Arguments + ========= - A (input) DOUBLE PRECISION array, dimension (LDA,K) - The i-th column must contain the vector which defines the ele- - mentary reflector H(i), for i = 1,2,...,k, as returned by DGE- - QRF in the first k columns of its array argument A. A is modi- - fied by the routine but restored on exit. + SIDE (input) CHARACTER*1 + = 'L': apply Q or Q' from the Left + = 'R': apply Q or Q' from the Right - LDA (input) INTEGER - The leading dimension of the array A. If SIDE = 'L', LDA >= - max(1,M); if SIDE = 'R', LDA >= max(1,N). + TRANS (input) CHARACTER*1 + = 'N': apply Q (No transpose) + = 'T': apply Q' (Transpose) - TAU (input) DOUBLE PRECISION array, dimension (K) - TAU(i) must contain the scalar factor of the elementary reflec- - tor H(i), as returned by DGEQRF. + M (input) INTEGER + The number of rows of the matrix C. M >= 0. - C (input/output) DOUBLE PRECISION array, dimension (LDC,N) - On entry, the m by n matrix C. On exit, C is overwritten by - Q*C or Q'*C or C*Q' or C*Q. + N (input) INTEGER + The number of columns of the matrix C. N >= 0. - LDC (input) INTEGER - The leading dimension of the array C. LDC >= max(1,M). + K (input) INTEGER + The number of elementary reflectors whose product defines + the matrix Q. + If SIDE = 'L', M >= K >= 0; + if SIDE = 'R', N >= K >= 0. - WORK (workspace) DOUBLE PRECISION array, dimension - (N) if SIDE = 'L', (M) if SIDE = 'R' + A (input) DOUBLE PRECISION array, dimension (LDA,K) + The i-th column must contain the vector which defines the + elementary reflector H(i), for i = 1,2,...,k, as returned by + DGEQRF in the first k columns of its array argument A. + A is modified by the routine but restored on exit. - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value + LDA (input) INTEGER + The leading dimension of the array A. + If SIDE = 'L', LDA >= max(1,M); + if SIDE = 'R', LDA >= max(1,N). + + TAU (input) DOUBLE PRECISION array, dimension (K) + TAU(i) must contain the scalar factor of the elementary + reflector H(i), as returned by DGEQRF. + + C (input/output) DOUBLE PRECISION array, dimension (LDC,N) + On entry, the m by n matrix C. + On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. + + LDC (input) INTEGER + The leading dimension of the array C. LDC >= max(1,M). + + WORK (workspace) DOUBLE PRECISION array, dimension + (N) if SIDE = 'L', + (M) if SIDE = 'R' + + INFO (output) INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value \end{chunk} +\begin{verbatim} + SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, 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 +* February 29, 1992 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + DOUBLE PRECISION AII +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLARF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORM2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) + $ THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H(i) is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H(i) +* + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), + $ LDC, WORK ) + A( I, I ) = AII + 10 CONTINUE + RETURN +* +* End of DORM2R +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dorm2r} (let* ((one 1.0)) (declare (type (double-float 1.0 1.0) one)) @@ -70480,100 +99103,293 @@ SYNOPSIS DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -PURPOSE - If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C with - SIDE = 'L' SIDE = 'R' TRANS = 'N': Q * C - C * Q TRANS = 'T': Q**T * C C * Q**T - - If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C with - SIDE = 'L' SIDE = 'R' - TRANS = 'N': P * C C * P - TRANS = 'T': P**T * C C * P**T - - Here Q and P**T are the orthogonal matrices determined by DGEBRD when - reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and - P**T are defined as products of elementary reflectors H(i) and G(i) - respectively. - - Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the order - of the orthogonal matrix Q or P**T that is applied. - - If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: if nq >= k, - Q = H(1) H(2) . . . H(k); - if nq < k, Q = H(1) H(2) . . . H(nq-1). - - If VECT = 'P', A is assumed to have been a K-by-NQ matrix: if k < nq, P - = G(1) G(2) . . . G(k); - if k >= nq, P = G(1) G(2) . . . G(nq-1). - - -ARGUMENTS - VECT (input) CHARACTER*1 - = 'Q': apply Q or Q**T; - = 'P': apply P or P**T. - - SIDE (input) CHARACTER*1 - = 'L': apply Q, Q**T, P or P**T from the Left; - = 'R': apply Q, Q**T, P or P**T from the Right. - - TRANS (input) CHARACTER*1 - = 'N': No transpose, apply Q or P; - = 'T': Transpose, apply Q**T or P**T. - - M (input) INTEGER - The number of rows of the matrix C. M >= 0. - - N (input) INTEGER - The number of columns of the matrix C. N >= 0. - - K (input) INTEGER - If VECT = 'Q', the number of columns in the original matrix - reduced by DGEBRD. If VECT = 'P', the number of rows in the - original matrix reduced by DGEBRD. K >= 0. - - A (input) DOUBLE PRECISION array, dimension - (LDA,min(nq,K)) if VECT = 'Q' (LDA,nq) if VECT = 'P' The - vectors which define the elementary reflectors H(i) and G(i), - whose products determine the matrices Q and P, as returned by - DGEBRD. - - LDA (input) INTEGER - The leading dimension of the array A. If VECT = 'Q', LDA >= - max(1,nq); if VECT = 'P', LDA >= max(1,min(nq,K)). - - TAU (input) DOUBLE PRECISION array, dimension (min(nq,K)) - TAU(i) must contain the scalar factor of the elementary reflec- - tor H(i) or G(i) which determines Q or P, as returned by DGEBRD - in the array argument TAUQ or TAUP. + Purpose + ======= + + If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C + with + SIDE = 'L' SIDE = 'R' + TRANS = 'N': Q * C C * Q + TRANS = 'T': Q**T * C C * Q**T + + If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C + with + SIDE = 'L' SIDE = 'R' + TRANS = 'N': P * C C * P + TRANS = 'T': P**T * C C * P**T + + Here Q and P**T are the orthogonal matrices determined by DGEBRD when + reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and + P**T are defined as products of elementary reflectors H(i) and G(i) + respectively. + + Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the + order of the orthogonal matrix Q or P**T that is applied. + + If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: + if nq >= k, Q = H(1) H(2) . . . H(k); + if nq < k, Q = H(1) H(2) . . . H(nq-1). + + If VECT = 'P', A is assumed to have been a K-by-NQ matrix: + if k < nq, P = G(1) G(2) . . . G(k); + if k >= nq, P = G(1) G(2) . . . G(nq-1). + + Arguments + ========= + + VECT (input) CHARACTER*1 + = 'Q': apply Q or Q**T; + = 'P': apply P or P**T. + + SIDE (input) CHARACTER*1 + = 'L': apply Q, Q**T, P or P**T from the Left; + = 'R': apply Q, Q**T, P or P**T from the Right. + + TRANS (input) CHARACTER*1 + = 'N': No transpose, apply Q or P; + = 'T': Transpose, apply Q**T or P**T. + + M (input) INTEGER + The number of rows of the matrix C. M >= 0. + + N (input) INTEGER + The number of columns of the matrix C. N >= 0. + + K (input) INTEGER + If VECT = 'Q', the number of columns in the original + matrix reduced by DGEBRD. + If VECT = 'P', the number of rows in the original + matrix reduced by DGEBRD. + K >= 0. + + A (input) DOUBLE PRECISION array, dimension + (LDA,min(nq,K)) if VECT = 'Q' + (LDA,nq) if VECT = 'P' + The vectors which define the elementary reflectors H(i) and + G(i), whose products determine the matrices Q and P, as + returned by DGEBRD. + + LDA (input) INTEGER + The leading dimension of the array A. + If VECT = 'Q', LDA >= max(1,nq); + if VECT = 'P', LDA >= max(1,min(nq,K)). + + TAU (input) DOUBLE PRECISION array, dimension (min(nq,K)) + TAU(i) must contain the scalar factor of the elementary + reflector H(i) or G(i) which determines Q or P, as returned + by DGEBRD in the array argument TAUQ or TAUP. + + C (input/output) DOUBLE PRECISION array, dimension (LDC,N) + On entry, the M-by-N matrix C. + On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q + or P*C or P**T*C or C*P or C*P**T. + + LDC (input) INTEGER + The leading dimension of the array C. LDC >= max(1,M). + + 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. + If SIDE = 'L', LWORK >= max(1,N); + if SIDE = 'R', LWORK >= max(1,M). + For optimum performance LWORK >= N*NB if SIDE = 'L', and + LWORK >= M*NB if SIDE = 'R', where NB is the optimal + blocksize. + + If LWORK = -1, then a workspace query is assumed; the routine + only calculates the optimal size of the WORK array, returns + this value as the first entry of the WORK array, and no error + message related to LWORK is issued by XERBLA. + + INFO (output) INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value - C (input/output) DOUBLE PRECISION array, dimension (LDC,N) - On entry, the M-by-N matrix C. On exit, C is overwritten by - Q*C or Q**T*C or C*Q**T or C*Q or P*C or P**T*C or C*P or - C*P**T. - - LDC (input) INTEGER - The leading dimension of the array C. LDC >= max(1,M). - - WORK (workspace/output) DOUBLE PRECISION array, dimension - (MAX(1,LWORK)) - On exit, if INFO = 0, WORK(1) returns the optimal LWORK. - - LWORK (input) INTEGER - The dimension of the array WORK. If SIDE = 'L', LWORK >= - max(1,N); if SIDE = 'R', LWORK >= max(1,M). For optimum per- - formance LWORK >= N*NB if SIDE = 'L', and LWORK >= M*NB if SIDE - = 'R', where NB is the optimal blocksize. - - If LWORK = -1, then a workspace query is assumed; the routine - only calculates the optimal size of the WORK array, returns - this value as the first entry of the WORK array, and no error - message related to LWORK is issued by XERBLA. +\end{chunk} - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value +\begin{verbatim} + SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, + $ LDC, 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 SIDE, TRANS, VECT + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN + CHARACTER TRANST + INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DORMLQ, DORMQR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + APPLYQ = LSAME( VECT, 'Q' ) + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q or P and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( K.LT.0 ) THEN + INFO = -6 + ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR. + $ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) ) + $ THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( APPLYQ ) THEN + IF( LEFT ) THEN + NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1, + $ -1 ) + ELSE + NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1, + $ -1 ) + END IF + ELSE + IF( LEFT ) THEN + NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M-1, N, M-1, + $ -1 ) + ELSE + NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N-1, N-1, + $ -1 ) + END IF + END IF + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMBR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + WORK( 1 ) = 1 + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* + IF( APPLYQ ) THEN +* +* Apply Q +* + IF( NQ.GE.K ) THEN +* +* Q was determined by a call to DGEBRD with nq >= k +* + CALL DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, IINFO ) + ELSE IF( NQ.GT.1 ) THEN +* +* Q was determined by a call to DGEBRD with nq < k +* + IF( LEFT ) THEN + MI = M - 1 + NI = N + I1 = 2 + I2 = 1 + ELSE + MI = M + NI = N - 1 + I1 = 1 + I2 = 2 + END IF + CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, + $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) + END IF + ELSE +* +* Apply P +* + IF( NOTRAN ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF + IF( NQ.GT.K ) THEN +* +* P was determined by a call to DGEBRD with nq > k +* + CALL DORMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, IINFO ) + ELSE IF( NQ.GT.1 ) THEN +* +* P was determined by a call to DGEBRD with nq <= k +* + IF( LEFT ) THEN + MI = M - 1 + NI = N + I1 = 2 + I2 = 1 + ELSE + MI = M + NI = N - 1 + I1 = 1 + I2 = 2 + END IF + CALL DORMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA, + $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO ) + END IF + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMBR +* + END -\end{chunk} +\end{verbatim} \begin{chunk}{LAPACK dormbr} (defun dormbr (vect side trans m n k a lda tau c ldc work lwork info) @@ -70799,68 +99615,210 @@ SYNOPSIS DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -PURPOSE - DORML2 overwrites the general real m by n matrix C with + Purpose + ======= - where Q is a real orthogonal matrix defined as the product of k elemen- - tary reflectors + DORML2 overwrites the general real m by n matrix C with - Q = H(k) . . . H(2) H(1) + Q * C if SIDE = 'L' and TRANS = 'N', or - as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n if - SIDE = 'R'. + Q'* C if SIDE = 'L' and TRANS = 'T', or + C * Q if SIDE = 'R' and TRANS = 'N', or -ARGUMENTS - SIDE (input) CHARACTER*1 - = 'L': apply Q or Q' from the Left - = 'R': apply Q or Q' from the Right + C * Q' if SIDE = 'R' and TRANS = 'T', - TRANS (input) CHARACTER*1 - = 'N': apply Q (No transpose) - = 'T': apply Q' (Transpose) + where Q is a real orthogonal matrix defined as the product of k + elementary reflectors - M (input) INTEGER - The number of rows of the matrix C. M >= 0. + Q = H(k) . . . H(2) H(1) - N (input) INTEGER - The number of columns of the matrix C. N >= 0. + as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n + if SIDE = 'R'. - K (input) INTEGER - The number of elementary reflectors whose product defines the - matrix Q. If SIDE = 'L', M >= K >= 0; if SIDE = 'R', N >= K >= - 0. + Arguments + ========= - A (input) DOUBLE PRECISION array, dimension - (LDA,M) if SIDE = 'L', (LDA,N) if SIDE = 'R' The i-th row must - contain the vector which defines the elementary reflector H(i), - for i = 1,2,...,k, as returned by DGELQF in the first k rows of - its array argument A. A is modified by the routine but - restored on exit. + SIDE (input) CHARACTER*1 + = 'L': apply Q or Q' from the Left + = 'R': apply Q or Q' from the Right - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,K). + TRANS (input) CHARACTER*1 + = 'N': apply Q (No transpose) + = 'T': apply Q' (Transpose) - TAU (input) DOUBLE PRECISION array, dimension (K) - TAU(i) must contain the scalar factor of the elementary reflec- - tor H(i), as returned by DGELQF. + M (input) INTEGER + The number of rows of the matrix C. M >= 0. - C (input/output) DOUBLE PRECISION array, dimension (LDC,N) - On entry, the m by n matrix C. On exit, C is overwritten by - Q*C or Q'*C or C*Q' or C*Q. + N (input) INTEGER + The number of columns of the matrix C. N >= 0. - LDC (input) INTEGER - The leading dimension of the array C. LDC >= max(1,M). + K (input) INTEGER + The number of elementary reflectors whose product defines + the matrix Q. + If SIDE = 'L', M >= K >= 0; + if SIDE = 'R', N >= K >= 0. - WORK (workspace) DOUBLE PRECISION array, dimension - (N) if SIDE = 'L', (M) if SIDE = 'R' + A (input) DOUBLE PRECISION array, dimension + (LDA,M) if SIDE = 'L', + (LDA,N) if SIDE = 'R' + The i-th row must contain the vector which defines the + elementary reflector H(i), for i = 1,2,...,k, as returned by + DGELQF in the first k rows of its array argument A. + A is modified by the routine but restored on exit. - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value + LDA (input) INTEGER + The leading dimension of the array A. LDA >= max(1,K). + + TAU (input) DOUBLE PRECISION array, dimension (K) + TAU(i) must contain the scalar factor of the elementary + reflector H(i), as returned by DGELQF. + + C (input/output) DOUBLE PRECISION array, dimension (LDC,N) + On entry, the m by n matrix C. + On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. + + LDC (input) INTEGER + The leading dimension of the array C. LDC >= max(1,M). + + WORK (workspace) DOUBLE PRECISION array, dimension + (N) if SIDE = 'L', + (M) if SIDE = 'R' + + INFO (output) INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value \end{chunk} +\begin{verbatim} + SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, 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 +* February 29, 1992 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + DOUBLE PRECISION AII +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLARF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORML2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) + $ THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H(i) is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H(i) +* + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ), + $ C( IC, JC ), LDC, WORK ) + A( I, I ) = AII + 10 CONTINUE + RETURN +* +* End of DORML2 +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dorml2} (let* ((one 1.0)) (declare (type (double-float 1.0 1.0) one)) @@ -70991,81 +99949,280 @@ SYNOPSIS DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -PURPOSE - DORMLQ overwrites the general real M-by-N matrix C with TRANS = 'T': - Q**T * C C * Q**T + Purpose + ======= - where Q is a real orthogonal matrix defined as the product of k elemen- - tary reflectors + DORMLQ overwrites the general real M-by-N matrix C with - Q = H(k) . . . H(2) H(1) + SIDE = 'L' SIDE = 'R' + TRANS = 'N': Q * C C * Q + TRANS = 'T': Q**T * C C * Q**T - as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N if - SIDE = 'R'. + where Q is a real orthogonal matrix defined as the product of k + elementary reflectors + Q = H(k) . . . H(2) H(1) -ARGUMENTS - SIDE (input) CHARACTER*1 - = 'L': apply Q or Q**T from the Left; - = 'R': apply Q or Q**T from the Right. + as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N + if SIDE = 'R'. - TRANS (input) CHARACTER*1 - = 'N': No transpose, apply Q; - = 'T': Transpose, apply Q**T. + Arguments + ========= - M (input) INTEGER - The number of rows of the matrix C. M >= 0. + SIDE (input) CHARACTER*1 + = 'L': apply Q or Q**T from the Left; + = 'R': apply Q or Q**T from the Right. - N (input) INTEGER - The number of columns of the matrix C. N >= 0. + TRANS (input) CHARACTER*1 + = 'N': No transpose, apply Q; + = 'T': Transpose, apply Q**T. - K (input) INTEGER - The number of elementary reflectors whose product defines the - matrix Q. If SIDE = 'L', M >= K >= 0; if SIDE = 'R', N >= K >= - 0. + M (input) INTEGER + The number of rows of the matrix C. M >= 0. - A (input) DOUBLE PRECISION array, dimension - (LDA,M) if SIDE = 'L', (LDA,N) if SIDE = 'R' The i-th row must - contain the vector which defines the elementary reflector H(i), - for i = 1,2,...,k, as returned by DGELQF in the first k rows of - its array argument A. A is modified by the routine but - restored on exit. + N (input) INTEGER + The number of columns of the matrix C. N >= 0. - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,K). + K (input) INTEGER + The number of elementary reflectors whose product defines + the matrix Q. + If SIDE = 'L', M >= K >= 0; + if SIDE = 'R', N >= K >= 0. - TAU (input) DOUBLE PRECISION array, dimension (K) - TAU(i) must contain the scalar factor of the elementary reflec- - tor H(i), as returned by DGELQF. + A (input) DOUBLE PRECISION array, dimension + (LDA,M) if SIDE = 'L', + (LDA,N) if SIDE = 'R' + The i-th row must contain the vector which defines the + elementary reflector H(i), for i = 1,2,...,k, as returned by + DGELQF in the first k rows of its array argument A. + A is modified by the routine but restored on exit. - C (input/output) DOUBLE PRECISION array, dimension (LDC,N) - On entry, the M-by-N matrix C. On exit, C is overwritten by - Q*C or Q**T*C or C*Q**T or C*Q. + LDA (input) INTEGER + The leading dimension of the array A. LDA >= max(1,K). - LDC (input) INTEGER - The leading dimension of the array C. LDC >= max(1,M). + TAU (input) DOUBLE PRECISION array, dimension (K) + TAU(i) must contain the scalar factor of the elementary + reflector H(i), as returned by DGELQF. - WORK (workspace/output) DOUBLE PRECISION array, dimension - (MAX(1,LWORK)) - On exit, if INFO = 0, WORK(1) returns the optimal LWORK. + C (input/output) DOUBLE PRECISION array, dimension (LDC,N) + On entry, the M-by-N matrix C. + On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. - LWORK (input) INTEGER - The dimension of the array WORK. If SIDE = 'L', LWORK >= - max(1,N); if SIDE = 'R', LWORK >= max(1,M). For optimum per- - formance LWORK >= N*NB if SIDE = 'L', and LWORK >= M*NB if SIDE - = 'R', where NB is the optimal blocksize. + LDC (input) INTEGER + The leading dimension of the array C. LDC >= max(1,M). - 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. + WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) + On exit, if INFO = 0, WORK(1) returns the optimal LWORK. - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value + LWORK (input) INTEGER + The dimension of the array WORK. + If SIDE = 'L', LWORK >= max(1,N); + if SIDE = 'R', LWORK >= max(1,M). + For optimum performance LWORK >= N*NB if SIDE = 'L', and + LWORK >= M*NB if SIDE = 'R', where NB is the optimal + blocksize. + + If LWORK = -1, then a workspace query is assumed; the routine + only calculates the optimal size of the WORK array, returns + this value as the first entry of the WORK array, and no error + message related to LWORK is issued by XERBLA. + + INFO (output) INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value \end{chunk} +\begin{verbatim} + SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ 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 SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + CHARACTER TRANST + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, + $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW +* .. +* .. Local Arrays .. + DOUBLE PRECISION T( LDT, NBMAX ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORML2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. NB may be at most NBMAX, where NBMAX +* is used to define the local array T. +* + NB = MIN( NBMAX, ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N, K, + $ -1 ) ) + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMLQ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMLQ', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* Use unblocked code +* + CALL DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, + $ IINFO ) + ELSE +* +* Use blocked code +* + IF( ( LEFT .AND. NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + IF( NOTRAN ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ), + $ LDA, TAU( I ), T, LDT ) + IF( LEFT ) THEN +* +* H or H' is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H or H' is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H or H' +* + CALL DLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB, + $ A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, WORK, + $ LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMLQ +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dormlq} (let* ((nbmax 64) (ldt (+ nbmax 1))) (declare (type (fixnum 64 64) nbmax) @@ -71269,81 +100426,273 @@ SYNOPSIS DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -PURPOSE - DORMQR overwrites the general real M-by-N matrix C with TRANS = 'T': - Q**T * C C * Q**T + Purpose + ======= - where Q is a real orthogonal matrix defined as the product of k elemen- - tary reflectors + DORMQR overwrites the general real M-by-N matrix C with - Q = H(1) H(2) . . . H(k) + SIDE = 'L' SIDE = 'R' + TRANS = 'N': Q * C C * Q + TRANS = 'T': Q**T * C C * Q**T - as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N if - SIDE = 'R'. + where Q is a real orthogonal matrix defined as the product of k + elementary reflectors + Q = H(1) H(2) . . . H(k) -ARGUMENTS - SIDE (input) CHARACTER*1 - = 'L': apply Q or Q**T from the Left; - = 'R': apply Q or Q**T from the Right. + as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N + if SIDE = 'R'. - TRANS (input) CHARACTER*1 - = 'N': No transpose, apply Q; - = 'T': Transpose, apply Q**T. + Arguments + ========= - M (input) INTEGER - The number of rows of the matrix C. M >= 0. + SIDE (input) CHARACTER*1 + = 'L': apply Q or Q**T from the Left; + = 'R': apply Q or Q**T from the Right. - N (input) INTEGER - The number of columns of the matrix C. N >= 0. + TRANS (input) CHARACTER*1 + = 'N': No transpose, apply Q; + = 'T': Transpose, apply Q**T. - K (input) INTEGER - The number of elementary reflectors whose product defines the - matrix Q. If SIDE = 'L', M >= K >= 0; if SIDE = 'R', N >= K >= - 0. + M (input) INTEGER + The number of rows of the matrix C. M >= 0. - A (input) DOUBLE PRECISION array, dimension (LDA,K) - The i-th column must contain the vector which defines the ele- - mentary reflector H(i), for i = 1,2,...,k, as returned by DGE- - QRF in the first k columns of its array argument A. A is modi- - fied by the routine but restored on exit. + N (input) INTEGER + The number of columns of the matrix C. N >= 0. - LDA (input) INTEGER - The leading dimension of the array A. If SIDE = 'L', LDA >= - max(1,M); if SIDE = 'R', LDA >= max(1,N). + K (input) INTEGER + The number of elementary reflectors whose product defines + the matrix Q. + If SIDE = 'L', M >= K >= 0; + if SIDE = 'R', N >= K >= 0. - TAU (input) DOUBLE PRECISION array, dimension (K) - TAU(i) must contain the scalar factor of the elementary reflec- - tor H(i), as returned by DGEQRF. + A (input) DOUBLE PRECISION array, dimension (LDA,K) + The i-th column must contain the vector which defines the + elementary reflector H(i), for i = 1,2,...,k, as returned by + DGEQRF in the first k columns of its array argument A. + A is modified by the routine but restored on exit. - C (input/output) DOUBLE PRECISION array, dimension (LDC,N) - On entry, the M-by-N matrix C. On exit, C is overwritten by - Q*C or Q**T*C or C*Q**T or C*Q. + LDA (input) INTEGER + The leading dimension of the array A. + If SIDE = 'L', LDA >= max(1,M); + if SIDE = 'R', LDA >= max(1,N). - LDC (input) INTEGER - The leading dimension of the array C. LDC >= max(1,M). + TAU (input) DOUBLE PRECISION array, dimension (K) + TAU(i) must contain the scalar factor of the elementary + reflector H(i), as returned by DGEQRF. - WORK (workspace/output) DOUBLE PRECISION array, dimension - (MAX(1,LWORK)) - On exit, if INFO = 0, WORK(1) returns the optimal LWORK. + C (input/output) DOUBLE PRECISION array, dimension (LDC,N) + On entry, the M-by-N matrix C. + On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. - LWORK (input) INTEGER - The dimension of the array WORK. If SIDE = 'L', LWORK >= - max(1,N); if SIDE = 'R', LWORK >= max(1,M). For optimum per- - formance LWORK >= N*NB if SIDE = 'L', and LWORK >= M*NB if SIDE - = 'R', where NB is the optimal blocksize. + LDC (input) INTEGER + The leading dimension of the array C. LDC >= max(1,M). - 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. + WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) + On exit, if INFO = 0, WORK(1) returns the optimal LWORK. - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value + LWORK (input) INTEGER + The dimension of the array WORK. + If SIDE = 'L', LWORK >= max(1,N); + if SIDE = 'R', LWORK >= max(1,M). + For optimum performance LWORK >= N*NB if SIDE = 'L', and + LWORK >= M*NB if SIDE = 'R', where NB is the optimal + blocksize. + + If LWORK = -1, then a workspace query is assumed; the routine + only calculates the optimal size of the WORK array, returns + this value as the first entry of the WORK array, and no error + message related to LWORK is issued by XERBLA. + + INFO (output) INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value \end{chunk} +\begin{verbatim} + SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ 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 SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, + $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW +* .. +* .. Local Arrays .. + DOUBLE PRECISION T( LDT, NBMAX ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. NB may be at most NBMAX, where NBMAX +* is used to define the local array T. +* + NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* Use unblocked code +* + CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, + $ IINFO ) + ELSE +* +* Use blocked code +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), + $ LDA, TAU( I ), T, LDT ) + IF( LEFT ) THEN +* +* H or H' is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H or H' is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H or H' +* + CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, + $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, + $ WORK, LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORMQR +* + END + +\end{verbatim} + \begin{chunk}{LAPACK dormqr} (let* ((nbmax 64) (ldt (+ nbmax 1))) (declare (type (fixnum 64 64) nbmax) @@ -71541,119 +100890,1016 @@ SYNOPSIS DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), WORK( * ) -PURPOSE - DTREVC computes some or all of the right and/or left eigenvectors of a - real upper quasi-triangular matrix T. Matrices of this type are pro- - duced by the Schur factorization of a real general matrix: A = - Q*T*Q**T, as computed by DHSEQR. - - The right eigenvector x and the left eigenvector y of T corresponding - to an eigenvalue w are defined by: - - T*x = w*x, (y**H)*T = w*(y**H) + Purpose + ======= + + DTREVC computes some or all of the right and/or left eigenvectors of + a real upper quasi-triangular matrix T. + + The right eigenvector x and the left eigenvector y of T corresponding + to an eigenvalue w are defined by: + + T*x = w*x, y'*T = w*y' + + where y' denotes the conjugate transpose of the vector y. + + If all eigenvectors are requested, the routine may either return the + matrices X and/or Y of right or left eigenvectors of T, or the + products Q*X and/or Q*Y, where Q is an input orthogonal + matrix. If T was obtained from the real-Schur factorization of an + original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of + right or left eigenvectors of A. + + T must be in Schur canonical form (as returned by DHSEQR), that is, + block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each + 2-by-2 diagonal block has its diagonal elements equal and its + off-diagonal elements of opposite sign. Corresponding to each 2-by-2 + diagonal block is a complex conjugate pair of eigenvalues and + eigenvectors; only one eigenvector of the pair is computed, namely + the one corresponding to the eigenvalue with positive imaginary part. + + Arguments + ========= + + SIDE (input) CHARACTER*1 + = 'R': compute right eigenvectors only; + = 'L': compute left eigenvectors only; + = 'B': compute both right and left eigenvectors. + + HOWMNY (input) CHARACTER*1 + = 'A': compute all right and/or left eigenvectors; + = 'B': compute all right and/or left eigenvectors, + and backtransform them using the input matrices + supplied in VR and/or VL; + = 'S': compute selected right and/or left eigenvectors, + specified by the logical array SELECT. + + SELECT (input/output) LOGICAL array, dimension (N) + If HOWMNY = 'S', SELECT specifies the eigenvectors to be + computed. + If HOWMNY = 'A' or 'B', SELECT is not referenced. + To select the real eigenvector corresponding to a real + eigenvalue w(j), SELECT(j) must be set to .TRUE.. To select + the complex eigenvector corresponding to a complex conjugate + pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must be + set to .TRUE.; then on exit SELECT(j) is .TRUE. and + SELECT(j+1) is .FALSE.. + + N (input) INTEGER + The order of the matrix T. N >= 0. + + T (input) DOUBLE PRECISION array, dimension (LDT,N) + The upper quasi-triangular matrix T in Schur canonical form. + + LDT (input) INTEGER + The leading dimension of the array T. LDT >= max(1,N). + + VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) + On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must + contain an N-by-N matrix Q (usually the orthogonal matrix Q + of Schur vectors returned by DHSEQR). + On exit, if SIDE = 'L' or 'B', VL contains: + if HOWMNY = 'A', the matrix Y of left eigenvectors of T; + VL has the same quasi-lower triangular form + as T'. If T(i,i) is a real eigenvalue, then + the i-th column VL(i) of VL is its + corresponding eigenvector. If T(i:i+1,i:i+1) + is a 2-by-2 block whose eigenvalues are + complex-conjugate eigenvalues of T, then + VL(i)+sqrt(-1)*VL(i+1) is the complex + eigenvector corresponding to the eigenvalue + with positive real part. + if HOWMNY = 'B', the matrix Q*Y; + if HOWMNY = 'S', the left eigenvectors of T specified by + SELECT, stored consecutively in the columns + of VL, in the same order as their + eigenvalues. + A complex eigenvector corresponding to a complex eigenvalue + is stored in two consecutive columns, the first holding the + real part, and the second the imaginary part. + If SIDE = 'R', VL is not referenced. + + LDVL (input) INTEGER + The leading dimension of the array VL. LDVL >= max(1,N) if + SIDE = 'L' or 'B'; LDVL >= 1 otherwise. + + VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) + On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must + contain an N-by-N matrix Q (usually the orthogonal matrix Q + of Schur vectors returned by DHSEQR). + On exit, if SIDE = 'R' or 'B', VR contains: + if HOWMNY = 'A', the matrix X of right eigenvectors of T; + VR has the same quasi-upper triangular form + as T. If T(i,i) is a real eigenvalue, then + the i-th column VR(i) of VR is its + corresponding eigenvector. If T(i:i+1,i:i+1) + is a 2-by-2 block whose eigenvalues are + complex-conjugate eigenvalues of T, then + VR(i)+sqrt(-1)*VR(i+1) is the complex + eigenvector corresponding to the eigenvalue + with positive real part. + if HOWMNY = 'B', the matrix Q*X; + if HOWMNY = 'S', the right eigenvectors of T specified by + SELECT, stored consecutively in the columns + of VR, in the same order as their + eigenvalues. + A complex eigenvector corresponding to a complex eigenvalue + is stored in two consecutive columns, the first holding the + real part and the second the imaginary part. + If SIDE = 'L', VR is not referenced. + + LDVR (input) INTEGER + The leading dimension of the array VR. LDVR >= max(1,N) if + SIDE = 'R' or 'B'; LDVR >= 1 otherwise. + + MM (input) INTEGER + The number of columns in the arrays VL and/or VR. MM >= M. + + M (output) INTEGER + The number of columns in the arrays VL and/or VR actually + used to store the eigenvectors. + If HOWMNY = 'A' or 'B', M is set to N. + Each selected real eigenvector occupies one column and each + selected complex eigenvector occupies two columns. + + WORK (workspace) DOUBLE PRECISION array, dimension (3*N) + + INFO (output) INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value + + Further Details + =============== + + The algorithm used in this program is basically backward (forward) + substitution, with scaling to make the the code robust against + possible overflow. + + Each eigenvector is normalized so that the element of largest + magnitude has magnitude 1; here the magnitude of a complex number + (x,y) is taken to be |x| + |y|. - where y**H denotes the conjugate transpose of y. - The eigenvalues are not input to this routine, but are read directly - from the diagonal blocks of T. - - This routine returns the matrices X and/or Y of right and left eigen- - vectors of T, or the products Q*X and/or Q*Y, where Q is an input - matrix. If Q is the orthogonal factor that reduces a matrix A to Schur - form T, then Q*X and Q*Y are the matrices of right and left eigenvec- - tors of A. - - -ARGUMENTS - SIDE (input) CHARACTER*1 - = 'R': compute right eigenvectors only; - = 'L': compute left eigenvectors only; - = 'B': compute both right and left eigenvectors. - - HOWMNY (input) CHARACTER*1 - = 'A': compute all right and/or left eigenvectors; - = 'B': compute all right and/or left eigenvectors, backtrans- - formed by the matrices in VR and/or VL; = 'S': compute - selected right and/or left eigenvectors, as indicated by the - logical array SELECT. - - SELECT (input/output) LOGICAL array, dimension (N) - If HOWMNY = 'S', SELECT specifies the eigenvectors to be com- - puted. If w(j) is a real eigenvalue, the corresponding real - eigenvector is computed if SELECT(j) is .TRUE.. If w(j) and - w(j+1) are the real and imaginary parts of a complex eigen- - value, the corresponding complex eigenvector is computed if - either SELECT(j) or SELECT(j+1) is .TRUE., and on exit - SELECT(j) is set to .TRUE. and SELECT(j+1) is set to Not refer- - enced if HOWMNY = 'A' or 'B'. - - N (input) INTEGER - The order of the matrix T. N >= 0. - - T (input) DOUBLE PRECISION array, dimension (LDT,N) - The upper quasi-triangular matrix T in Schur canonical form. - - LDT (input) INTEGER - The leading dimension of the array T. LDT >= max(1,N). - - VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) - On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must con- - tain an N-by-N matrix Q (usually the orthogonal matrix Q of - Schur vectors returned by DHSEQR). On exit, if SIDE = 'L' or - 'B', VL contains: if HOWMNY = 'A', the matrix Y of left eigen- - vectors of T; if HOWMNY = 'B', the matrix Q*Y; if HOWMNY = 'S', - the left eigenvectors of T specified by SELECT, stored consecu- - tively in the columns of VL, in the same order as their eigen- - values. A complex eigenvector corresponding to a complex - eigenvalue is stored in two consecutive columns, the first - holding the real part, and the second the imaginary part. Not - referenced if SIDE = 'R'. - - LDVL (input) INTEGER - The leading dimension of the array VL. LDVL >= 1, and if SIDE - = 'L' or 'B', LDVL >= N. - - VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) - On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must con- - tain an N-by-N matrix Q (usually the orthogonal matrix Q of - Schur vectors returned by DHSEQR). On exit, if SIDE = 'R' or - 'B', VR contains: if HOWMNY = 'A', the matrix X of right eigen- - vectors of T; if HOWMNY = 'B', the matrix Q*X; if HOWMNY = 'S', - the right eigenvectors of T specified by SELECT, stored consec- - utively in the columns of VR, in the same order as their eigen- - values. A complex eigenvector corresponding to a complex - eigenvalue is stored in two consecutive columns, the first - holding the real part and the second the imaginary part. Not - referenced if SIDE = 'L'. - - LDVR (input) INTEGER - The leading dimension of the array VR. LDVR >= 1, and if SIDE - = 'R' or 'B', LDVR >= N. - - MM (input) INTEGER - The number of columns in the arrays VL and/or VR. MM >= M. - - M (output) INTEGER - The number of columns in the arrays VL and/or VR actually used - to store the eigenvectors. If HOWMNY = 'A' or 'B', M is set to - N. Each selected real eigenvector occupies one column and each - selected complex eigenvector occupies two columns. - - WORK (workspace) DOUBLE PRECISION array, dimension (3*N) - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - -FURTHER DETAILS - The algorithm used in this program is basically backward (forward) sub- - stitution, with scaling to make the the code robust against possible - overflow. +\end{chunk} - Each eigenvector is normalized so that the element of largest magnitude - has magnitude 1; here the magnitude of a complex number (x,y) is taken - to be |x| + |y|. +\begin{verbatim} + SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, + $ LDVR, MM, M, WORK, 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 HOWMNY, SIDE + INTEGER INFO, LDT, LDVL, LDVR, M, MM, N +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV + INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2 + DOUBLE PRECISION BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE, + $ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR, + $ XNORM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DDOT, DLAMCH + EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DLALN2, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Local Arrays .. + DOUBLE PRECISION X( 2, 2 ) +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + BOTHV = LSAME( SIDE, 'B' ) + RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV + LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV +* + ALLV = LSAME( HOWMNY, 'A' ) + OVER = LSAME( HOWMNY, 'B' ) + SOMEV = LSAME( HOWMNY, 'S' ) +* + INFO = 0 + IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN + INFO = -1 + ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN + INFO = -10 + ELSE +* +* Set M to the number of columns required to store the selected +* eigenvectors, standardize the array SELECT if necessary, and +* test MM. +* + IF( SOMEV ) THEN + M = 0 + PAIR = .FALSE. + DO 10 J = 1, N + IF( PAIR ) THEN + PAIR = .FALSE. + SELECT( J ) = .FALSE. + ELSE + IF( J.LT.N ) THEN + IF( T( J+1, J ).EQ.ZERO ) THEN + IF( SELECT( J ) ) + $ M = M + 1 + ELSE + PAIR = .TRUE. + IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN + SELECT( J ) = .TRUE. + M = M + 2 + END IF + END IF + ELSE + IF( SELECT( N ) ) + $ M = M + 1 + END IF + END IF + 10 CONTINUE + ELSE + M = N + END IF +* + IF( MM.LT.M ) THEN + INFO = -11 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTREVC', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* +* Set the constants to control overflow. +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Precision' ) + SMLNUM = UNFL*( N / ULP ) + BIGNUM = ( ONE-ULP ) / SMLNUM +* +* Compute 1-norm of each column of strictly upper triangular +* part of T to control overflow in triangular solver. +* + WORK( 1 ) = ZERO + DO 30 J = 2, N + WORK( J ) = ZERO + DO 20 I = 1, J - 1 + WORK( J ) = WORK( J ) + ABS( T( I, J ) ) + 20 CONTINUE + 30 CONTINUE +* +* Index IP is used to specify the real or complex eigenvalue: +* IP = 0, real eigenvalue, +* 1, first of conjugate complex pair: (wr,wi) +* -1, second of conjugate complex pair: (wr,wi) +* + N2 = 2*N +* + IF( RIGHTV ) THEN +* +* Compute right eigenvectors. +* + IP = 0 + IS = M + DO 140 KI = N, 1, -1 +* + IF( IP.EQ.1 ) + $ GO TO 130 + IF( KI.EQ.1 ) + $ GO TO 40 + IF( T( KI, KI-1 ).EQ.ZERO ) + $ GO TO 40 + IP = -1 +* + 40 CONTINUE + IF( SOMEV ) THEN + IF( IP.EQ.0 ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 130 + ELSE + IF( .NOT.SELECT( KI-1 ) ) + $ GO TO 130 + END IF + END IF +* +* Compute the KI-th eigenvalue (WR,WI). +* + WR = T( KI, KI ) + WI = ZERO + IF( IP.NE.0 ) + $ WI = SQRT( ABS( T( KI, KI-1 ) ) )* + $ SQRT( ABS( T( KI-1, KI ) ) ) + SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) +* + IF( IP.EQ.0 ) THEN +* +* Real right eigenvector +* + WORK( KI+N ) = ONE +* +* Form right-hand side +* + DO 50 K = 1, KI - 1 + WORK( K+N ) = -T( K, KI ) + 50 CONTINUE +* +* Solve the upper quasi-triangular system: +* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. +* + JNXT = KI - 1 + DO 60 J = KI - 1, 1, -1 + IF( J.GT.JNXT ) + $ GO TO 60 + J1 = J + J2 = J + JNXT = J - 1 + IF( J.GT.1 ) THEN + IF( T( J, J-1 ).NE.ZERO ) THEN + J1 = J - 1 + JNXT = J - 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* + CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+N ), N, WR, + $ ZERO, X, 2, SCALE, XNORM, IERR ) +* +* Scale X(1,1) to avoid overflow when updating +* the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + IF( WORK( J ).GT.BIGNUM / XNORM ) THEN + X( 1, 1 ) = X( 1, 1 ) / XNORM + SCALE = SCALE / XNORM + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) + WORK( J+N ) = X( 1, 1 ) +* +* Update right-hand side +* + CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, + $ WORK( 1+N ), 1 ) +* + ELSE +* +* 2-by-2 diagonal block +* + CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, + $ T( J-1, J-1 ), LDT, ONE, ONE, + $ WORK( J-1+N ), N, WR, ZERO, X, 2, + $ SCALE, XNORM, IERR ) +* +* Scale X(1,1) and X(2,1) to avoid overflow when +* updating the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + BETA = MAX( WORK( J-1 ), WORK( J ) ) + IF( BETA.GT.BIGNUM / XNORM ) THEN + X( 1, 1 ) = X( 1, 1 ) / XNORM + X( 2, 1 ) = X( 2, 1 ) / XNORM + SCALE = SCALE / XNORM + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) + WORK( J-1+N ) = X( 1, 1 ) + WORK( J+N ) = X( 2, 1 ) +* +* Update right-hand side +* + CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, + $ WORK( 1+N ), 1 ) + CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, + $ WORK( 1+N ), 1 ) + END IF + 60 CONTINUE +* +* Copy the vector x or Q*x to VR and normalize. +* + IF( .NOT.OVER ) THEN + CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS ), 1 ) +* + II = IDAMAX( KI, VR( 1, IS ), 1 ) + REMAX = ONE / ABS( VR( II, IS ) ) + CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) +* + DO 70 K = KI + 1, N + VR( K, IS ) = ZERO + 70 CONTINUE + ELSE + IF( KI.GT.1 ) + $ CALL DGEMV( 'N', N, KI-1, ONE, VR, LDVR, + $ WORK( 1+N ), 1, WORK( KI+N ), + $ VR( 1, KI ), 1 ) +* + II = IDAMAX( N, VR( 1, KI ), 1 ) + REMAX = ONE / ABS( VR( II, KI ) ) + CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) + END IF +* + ELSE +* +* Complex right eigenvector. +* +* Initial solve +* [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0. +* [ (T(KI,KI-1) T(KI,KI) ) ] +* + IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN + WORK( KI-1+N ) = ONE + WORK( KI+N2 ) = WI / T( KI-1, KI ) + ELSE + WORK( KI-1+N ) = -WI / T( KI, KI-1 ) + WORK( KI+N2 ) = ONE + END IF + WORK( KI+N ) = ZERO + WORK( KI-1+N2 ) = ZERO +* +* Form right-hand side +* + DO 80 K = 1, KI - 2 + WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 ) + WORK( K+N2 ) = -WORK( KI+N2 )*T( K, KI ) + 80 CONTINUE +* +* Solve upper quasi-triangular system: +* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) +* + JNXT = KI - 2 + DO 90 J = KI - 2, 1, -1 + IF( J.GT.JNXT ) + $ GO TO 90 + J1 = J + J2 = J + JNXT = J - 1 + IF( J.GT.1 ) THEN + IF( T( J, J-1 ).NE.ZERO ) THEN + J1 = J - 1 + JNXT = J - 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* + CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+N ), N, WR, WI, + $ X, 2, SCALE, XNORM, IERR ) +* +* Scale X(1,1) and X(1,2) to avoid overflow when +* updating the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + IF( WORK( J ).GT.BIGNUM / XNORM ) THEN + X( 1, 1 ) = X( 1, 1 ) / XNORM + X( 1, 2 ) = X( 1, 2 ) / XNORM + SCALE = SCALE / XNORM + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) + CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) + END IF + WORK( J+N ) = X( 1, 1 ) + WORK( J+N2 ) = X( 1, 2 ) +* +* Update the right-hand side +* + CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, + $ WORK( 1+N ), 1 ) + CALL DAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1, + $ WORK( 1+N2 ), 1 ) +* + ELSE +* +* 2-by-2 diagonal block +* + CALL DLALN2( .FALSE., 2, 2, SMIN, ONE, + $ T( J-1, J-1 ), LDT, ONE, ONE, + $ WORK( J-1+N ), N, WR, WI, X, 2, SCALE, + $ XNORM, IERR ) +* +* Scale X to avoid overflow when updating +* the right-hand side. +* + IF( XNORM.GT.ONE ) THEN + BETA = MAX( WORK( J-1 ), WORK( J ) ) + IF( BETA.GT.BIGNUM / XNORM ) THEN + REC = ONE / XNORM + X( 1, 1 ) = X( 1, 1 )*REC + X( 1, 2 ) = X( 1, 2 )*REC + X( 2, 1 ) = X( 2, 1 )*REC + X( 2, 2 ) = X( 2, 2 )*REC + SCALE = SCALE*REC + END IF + END IF +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) + CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) + END IF + WORK( J-1+N ) = X( 1, 1 ) + WORK( J+N ) = X( 2, 1 ) + WORK( J-1+N2 ) = X( 1, 2 ) + WORK( J+N2 ) = X( 2, 2 ) +* +* Update the right-hand side +* + CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, + $ WORK( 1+N ), 1 ) + CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, + $ WORK( 1+N ), 1 ) + CALL DAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1, + $ WORK( 1+N2 ), 1 ) + CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, + $ WORK( 1+N2 ), 1 ) + END IF + 90 CONTINUE +* +* Copy the vector x or Q*x to VR and normalize. +* + IF( .NOT.OVER ) THEN + CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 ) + CALL DCOPY( KI, WORK( 1+N2 ), 1, VR( 1, IS ), 1 ) +* + EMAX = ZERO + DO 100 K = 1, KI + EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+ + $ ABS( VR( K, IS ) ) ) + 100 CONTINUE +* + REMAX = ONE / EMAX + CALL DSCAL( KI, REMAX, VR( 1, IS-1 ), 1 ) + CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) +* + DO 110 K = KI + 1, N + VR( K, IS-1 ) = ZERO + VR( K, IS ) = ZERO + 110 CONTINUE +* + ELSE +* + IF( KI.GT.2 ) THEN + CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, + $ WORK( 1+N ), 1, WORK( KI-1+N ), + $ VR( 1, KI-1 ), 1 ) + CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, + $ WORK( 1+N2 ), 1, WORK( KI+N2 ), + $ VR( 1, KI ), 1 ) + ELSE + CALL DSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 ) + CALL DSCAL( N, WORK( KI+N2 ), VR( 1, KI ), 1 ) + END IF +* + EMAX = ZERO + DO 120 K = 1, N + EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+ + $ ABS( VR( K, KI ) ) ) + 120 CONTINUE + REMAX = ONE / EMAX + CALL DSCAL( N, REMAX, VR( 1, KI-1 ), 1 ) + CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) + END IF + END IF +* + IS = IS - 1 + IF( IP.NE.0 ) + $ IS = IS - 1 + 130 CONTINUE + IF( IP.EQ.1 ) + $ IP = 0 + IF( IP.EQ.-1 ) + $ IP = 1 + 140 CONTINUE + END IF +* + IF( LEFTV ) THEN +* +* Compute left eigenvectors. +* + IP = 0 + IS = 1 + DO 260 KI = 1, N +* + IF( IP.EQ.-1 ) + $ GO TO 250 + IF( KI.EQ.N ) + $ GO TO 150 + IF( T( KI+1, KI ).EQ.ZERO ) + $ GO TO 150 + IP = 1 +* + 150 CONTINUE + IF( SOMEV ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 250 + END IF +* +* Compute the KI-th eigenvalue (WR,WI). +* + WR = T( KI, KI ) + WI = ZERO + IF( IP.NE.0 ) + $ WI = SQRT( ABS( T( KI, KI+1 ) ) )* + $ SQRT( ABS( T( KI+1, KI ) ) ) + SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) +* + IF( IP.EQ.0 ) THEN +* +* Real left eigenvector. +* + WORK( KI+N ) = ONE +* +* Form right-hand side +* + DO 160 K = KI + 1, N + WORK( K+N ) = -T( KI, K ) + 160 CONTINUE +* +* Solve the quasi-triangular system: +* (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK +* + VMAX = ONE + VCRIT = BIGNUM +* + JNXT = KI + 1 + DO 170 J = KI + 1, N + IF( J.LT.JNXT ) + $ GO TO 170 + J1 = J + J2 = J + JNXT = J + 1 + IF( J.LT.N ) THEN + IF( T( J+1, J ).NE.ZERO ) THEN + J2 = J + 1 + JNXT = J + 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* +* Scale if necessary to avoid overflow when forming +* the right-hand side. +* + IF( WORK( J ).GT.VCRIT ) THEN + REC = ONE / VMAX + CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+N ) = WORK( J+N ) - + $ DDOT( J-KI-1, T( KI+1, J ), 1, + $ WORK( KI+1+N ), 1 ) +* +* Solve (T(J,J)-WR)'*X = WORK +* + CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+N ), N, WR, + $ ZERO, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) + WORK( J+N ) = X( 1, 1 ) + VMAX = MAX( ABS( WORK( J+N ) ), VMAX ) + VCRIT = BIGNUM / VMAX +* + ELSE +* +* 2-by-2 diagonal block +* +* Scale if necessary to avoid overflow when forming +* the right-hand side. +* + BETA = MAX( WORK( J ), WORK( J+1 ) ) + IF( BETA.GT.VCRIT ) THEN + REC = ONE / VMAX + CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+N ) = WORK( J+N ) - + $ DDOT( J-KI-1, T( KI+1, J ), 1, + $ WORK( KI+1+N ), 1 ) +* + WORK( J+1+N ) = WORK( J+1+N ) - + $ DDOT( J-KI-1, T( KI+1, J+1 ), 1, + $ WORK( KI+1+N ), 1 ) +* +* Solve +* [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 ) +* [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 ) +* + CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+N ), N, WR, + $ ZERO, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) + $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) + WORK( J+N ) = X( 1, 1 ) + WORK( J+1+N ) = X( 2, 1 ) +* + VMAX = MAX( ABS( WORK( J+N ) ), + $ ABS( WORK( J+1+N ) ), VMAX ) + VCRIT = BIGNUM / VMAX +* + END IF + 170 CONTINUE +* +* Copy the vector x or Q*x to VL and normalize. +* + IF( .NOT.OVER ) THEN + CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) +* + II = IDAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 + REMAX = ONE / ABS( VL( II, IS ) ) + CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) +* + DO 180 K = 1, KI - 1 + VL( K, IS ) = ZERO + 180 CONTINUE +* + ELSE +* + IF( KI.LT.N ) + $ CALL DGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL, + $ WORK( KI+1+N ), 1, WORK( KI+N ), + $ VL( 1, KI ), 1 ) +* + II = IDAMAX( N, VL( 1, KI ), 1 ) + REMAX = ONE / ABS( VL( II, KI ) ) + CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) +* + END IF +* + ELSE +* +* Complex left eigenvector. +* +* Initial solve: +* ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0. +* ((T(KI+1,KI) T(KI+1,KI+1)) ) +* + IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN + WORK( KI+N ) = WI / T( KI, KI+1 ) + WORK( KI+1+N2 ) = ONE + ELSE + WORK( KI+N ) = ONE + WORK( KI+1+N2 ) = -WI / T( KI+1, KI ) + END IF + WORK( KI+1+N ) = ZERO + WORK( KI+N2 ) = ZERO +* +* Form right-hand side +* + DO 190 K = KI + 2, N + WORK( K+N ) = -WORK( KI+N )*T( KI, K ) + WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K ) + 190 CONTINUE +* +* Solve complex quasi-triangular system: +* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 +* + VMAX = ONE + VCRIT = BIGNUM +* + JNXT = KI + 2 + DO 200 J = KI + 2, N + IF( J.LT.JNXT ) + $ GO TO 200 + J1 = J + J2 = J + JNXT = J + 1 + IF( J.LT.N ) THEN + IF( T( J+1, J ).NE.ZERO ) THEN + J2 = J + 1 + JNXT = J + 2 + END IF + END IF +* + IF( J1.EQ.J2 ) THEN +* +* 1-by-1 diagonal block +* +* Scale if necessary to avoid overflow when +* forming the right-hand side elements. +* + IF( WORK( J ).GT.VCRIT ) THEN + REC = ONE / VMAX + CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) + CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+N ) = WORK( J+N ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+N ), 1 ) + WORK( J+N2 ) = WORK( J+N2 ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+N2 ), 1 ) +* +* Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2 +* + CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+N ), N, WR, + $ -WI, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) + CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) + END IF + WORK( J+N ) = X( 1, 1 ) + WORK( J+N2 ) = X( 1, 2 ) + VMAX = MAX( ABS( WORK( J+N ) ), + $ ABS( WORK( J+N2 ) ), VMAX ) + VCRIT = BIGNUM / VMAX +* + ELSE +* +* 2-by-2 diagonal block +* +* Scale if necessary to avoid overflow when forming +* the right-hand side elements. +* + BETA = MAX( WORK( J ), WORK( J+1 ) ) + IF( BETA.GT.VCRIT ) THEN + REC = ONE / VMAX + CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) + CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) + VMAX = ONE + VCRIT = BIGNUM + END IF +* + WORK( J+N ) = WORK( J+N ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+N ), 1 ) +* + WORK( J+N2 ) = WORK( J+N2 ) - + $ DDOT( J-KI-2, T( KI+2, J ), 1, + $ WORK( KI+2+N2 ), 1 ) +* + WORK( J+1+N ) = WORK( J+1+N ) - + $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, + $ WORK( KI+2+N ), 1 ) +* + WORK( J+1+N2 ) = WORK( J+1+N2 ) - + $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, + $ WORK( KI+2+N2 ), 1 ) +* +* Solve 2-by-2 complex linear equation +* ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B +* ([T(j+1,j) T(j+1,j+1)] ) +* + CALL DLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ), + $ LDT, ONE, ONE, WORK( J+N ), N, WR, + $ -WI, X, 2, SCALE, XNORM, IERR ) +* +* Scale if necessary +* + IF( SCALE.NE.ONE ) THEN + CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) + CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) + END IF + WORK( J+N ) = X( 1, 1 ) + WORK( J+N2 ) = X( 1, 2 ) + WORK( J+1+N ) = X( 2, 1 ) + WORK( J+1+N2 ) = X( 2, 2 ) + VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ), + $ ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), VMAX ) + VCRIT = BIGNUM / VMAX +* + END IF + 200 CONTINUE +* +* Copy the vector x or Q*x to VL and normalize. +* + 210 CONTINUE + IF( .NOT.OVER ) THEN + CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) + CALL DCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ), + $ 1 ) +* + EMAX = ZERO + DO 220 K = KI, N + EMAX = MAX( EMAX, ABS( VL( K, IS ) )+ + $ ABS( VL( K, IS+1 ) ) ) + 220 CONTINUE + REMAX = ONE / EMAX + CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) + CALL DSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 ) +* + DO 230 K = 1, KI - 1 + VL( K, IS ) = ZERO + VL( K, IS+1 ) = ZERO + 230 CONTINUE + ELSE + IF( KI.LT.N-1 ) THEN + CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), + $ LDVL, WORK( KI+2+N ), 1, WORK( KI+N ), + $ VL( 1, KI ), 1 ) + CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), + $ LDVL, WORK( KI+2+N2 ), 1, + $ WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) + ELSE + CALL DSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 ) + CALL DSCAL( N, WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) + END IF +* + EMAX = ZERO + DO 240 K = 1, N + EMAX = MAX( EMAX, ABS( VL( K, KI ) )+ + $ ABS( VL( K, KI+1 ) ) ) + 240 CONTINUE + REMAX = ONE / EMAX + CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) + CALL DSCAL( N, REMAX, VL( 1, KI+1 ), 1 ) +* + END IF +* + END IF +* + IS = IS + 1 + IF( IP.NE.0 ) + $ IS = IS + 1 + 250 CONTINUE + IF( IP.EQ.-1 ) + $ IP = 0 + IF( IP.EQ.1 ) + $ IP = -1 +* + 260 CONTINUE +* + END IF +* + RETURN +* +* End of DTREVC +* + END -\end{chunk} +\end{verbatim} \begin{chunk}{LAPACK dtrevc} (let* ((zero 0.0) (one 1.0)) @@ -73640,67 +103886,357 @@ SYNOPSIS DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) -PURPOSE - DTREXC reorders the real Schur factorization of a real matrix A = - Q*T*Q**T, so that the diagonal block of T with row index IFST is moved - to row ILST. - - The real Schur form T is reordered by an orthogonal similarity trans- - formation Z**T*T*Z, and optionally the matrix Q of Schur vectors is - updated by postmultiplying it with Z. + Purpose + ======= + + DTREXC reorders the real Schur factorization of a real matrix + A = Q*T*Q**T, so that the diagonal block of T with row index IFST is + moved to row ILST. + + The real Schur form T is reordered by an orthogonal similarity + transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors + is updated by postmultiplying it with Z. + + T must be in Schur canonical form (as returned by DHSEQR), that is, + block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each + 2-by-2 diagonal block has its diagonal elements equal and its + off-diagonal elements of opposite sign. + + Arguments + ========= + + COMPQ (input) CHARACTER*1 + = 'V': update the matrix Q of Schur vectors; + = 'N': do not update Q. + + N (input) INTEGER + The order of the matrix T. N >= 0. + + T (input/output) DOUBLE PRECISION array, dimension (LDT,N) + On entry, the upper quasi-triangular matrix T, in Schur + Schur canonical form. + On exit, the reordered upper quasi-triangular matrix, again + in Schur canonical form. + + LDT (input) INTEGER + The leading dimension of the array T. LDT >= max(1,N). + + Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) + On entry, if COMPQ = 'V', the matrix Q of Schur vectors. + On exit, if COMPQ = 'V', Q has been postmultiplied by the + orthogonal transformation matrix Z which reorders T. + If COMPQ = 'N', Q is not referenced. + + LDQ (input) INTEGER + The leading dimension of the array Q. LDQ >= max(1,N). + + IFST (input/output) INTEGER + ILST (input/output) INTEGER + Specify the reordering of the diagonal blocks of T. + The block with row index IFST is moved to row ILST, by a + sequence of transpositions between adjacent blocks. + On exit, if IFST pointed on entry to the second row of a + 2-by-2 block, it is changed to point to the first row; ILST + always points to the first row of the block in its final + position (which may differ from its input value by +1 or -1). + 1 <= IFST <= N; 1 <= ILST <= N. + + WORK (workspace) DOUBLE PRECISION array, dimension (N) + + INFO (output) INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value + = 1: two adjacent blocks were too close to swap (the problem + is very ill-conditioned); T may have been partially + reordered, and ILST points to the first row of the + current position of the block being moved. - T must be in Schur canonical form (as returned by DHSEQR), that is, - block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each - 2-by-2 diagonal block has its diagonal elements equal and its off-diag- - onal elements of opposite sign. - - -ARGUMENTS - COMPQ (input) CHARACTER*1 - = 'V': update the matrix Q of Schur vectors; - = 'N': do not update Q. - - N (input) INTEGER - The order of the matrix T. N >= 0. - - T (input/output) DOUBLE PRECISION array, dimension (LDT,N) - On entry, the upper quasi-triangular matrix T, in Schur Schur - canonical form. On exit, the reordered upper quasi-triangular - matrix, again in Schur canonical form. - - LDT (input) INTEGER - The leading dimension of the array T. LDT >= max(1,N). - - Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) - On entry, if COMPQ = 'V', the matrix Q of Schur vectors. On - exit, if COMPQ = 'V', Q has been postmultiplied by the orthogo- - nal transformation matrix Z which reorders T. If COMPQ = 'N', - Q is not referenced. - - LDQ (input) INTEGER - The leading dimension of the array Q. LDQ >= max(1,N). - - IFST (input/output) INTEGER - ILST (input/output) INTEGER Specify the reordering of the - diagonal blocks of T. The block with row index IFST is moved - to row ILST, by a sequence of transpositions between adjacent - blocks. On exit, if IFST pointed on entry to the second row of - a 2-by-2 block, it is changed to point to the first row; ILST - always points to the first row of the block in its final posi- - tion (which may differ from its input value by +1 or -1). 1 <= - IFST <= N; 1 <= ILST <= N. - - WORK (workspace) DOUBLE PRECISION array, dimension (N) +\end{chunk} - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - = 1: two adjacent blocks were too close to swap (the problem - is very ill-conditioned); T may have been partially reordered, - and ILST points to the first row of the current position of the - block being moved. +\begin{verbatim} + SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, + $ 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 COMPQ + INTEGER IFST, ILST, INFO, LDQ, LDT, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL WANTQ + INTEGER HERE, NBF, NBL, NBNEXT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLAEXC, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Decode and test the input arguments. +* + INFO = 0 + WANTQ = LSAME( COMPQ, 'V' ) + IF( .NOT.WANTQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN + INFO = -6 + ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN + INFO = -7 + ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTREXC', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* +* Determine the first row of specified block +* and find out it is 1 by 1 or 2 by 2. +* + IF( IFST.GT.1 ) THEN + IF( T( IFST, IFST-1 ).NE.ZERO ) + $ IFST = IFST - 1 + END IF + NBF = 1 + IF( IFST.LT.N ) THEN + IF( T( IFST+1, IFST ).NE.ZERO ) + $ NBF = 2 + END IF +* +* Determine the first row of the final block +* and find out it is 1 by 1 or 2 by 2. +* + IF( ILST.GT.1 ) THEN + IF( T( ILST, ILST-1 ).NE.ZERO ) + $ ILST = ILST - 1 + END IF + NBL = 1 + IF( ILST.LT.N ) THEN + IF( T( ILST+1, ILST ).NE.ZERO ) + $ NBL = 2 + END IF +* + IF( IFST.EQ.ILST ) + $ RETURN +* + IF( IFST.LT.ILST ) THEN +* +* Update ILST +* + IF( NBF.EQ.2 .AND. NBL.EQ.1 ) + $ ILST = ILST - 1 + IF( NBF.EQ.1 .AND. NBL.EQ.2 ) + $ ILST = ILST + 1 +* + HERE = IFST +* + 10 CONTINUE +* +* Swap block with next one below +* + IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN +* +* Current block either 1 by 1 or 2 by 2 +* + NBNEXT = 1 + IF( HERE+NBF+1.LE.N ) THEN + IF( T( HERE+NBF+1, HERE+NBF ).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBF, NBNEXT, + $ WORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE + NBNEXT +* +* Test if 2 by 2 block breaks into two 1 by 1 blocks +* + IF( NBF.EQ.2 ) THEN + IF( T( HERE+1, HERE ).EQ.ZERO ) + $ NBF = 3 + END IF +* + ELSE +* +* Current block consists of two 1 by 1 blocks each of which +* must be swapped individually +* + NBNEXT = 1 + IF( HERE+3.LE.N ) THEN + IF( T( HERE+3, HERE+2 ).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, NBNEXT, + $ WORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + IF( NBNEXT.EQ.1 ) THEN +* +* Swap two 1 by 1 blocks, no problems possible +* + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, NBNEXT, + $ WORK, INFO ) + HERE = HERE + 1 + ELSE +* +* Recompute NBNEXT in case 2 by 2 split +* + IF( T( HERE+2, HERE+1 ).EQ.ZERO ) + $ NBNEXT = 1 + IF( NBNEXT.EQ.2 ) THEN +* +* 2 by 2 Block did not split +* + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, + $ NBNEXT, WORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE + 2 + ELSE +* +* 2 by 2 Block did split +* + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, + $ WORK, INFO ) + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, 1, + $ WORK, INFO ) + HERE = HERE + 2 + END IF + END IF + END IF + IF( HERE.LT.ILST ) + $ GO TO 10 +* + ELSE +* + HERE = IFST + 20 CONTINUE +* +* Swap block with next one above +* + IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN +* +* Current block either 1 by 1 or 2 by 2 +* + NBNEXT = 1 + IF( HERE.GE.3 ) THEN + IF( T( HERE-1, HERE-2 ).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, + $ NBF, WORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE - NBNEXT +* +* Test if 2 by 2 block breaks into two 1 by 1 blocks +* + IF( NBF.EQ.2 ) THEN + IF( T( HERE+1, HERE ).EQ.ZERO ) + $ NBF = 3 + END IF +* + ELSE +* +* Current block consists of two 1 by 1 blocks each of which +* must be swapped individually +* + NBNEXT = 1 + IF( HERE.GE.3 ) THEN + IF( T( HERE-1, HERE-2 ).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, + $ 1, WORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + IF( NBNEXT.EQ.1 ) THEN +* +* Swap two 1 by 1 blocks, no problems possible +* + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBNEXT, 1, + $ WORK, INFO ) + HERE = HERE - 1 + ELSE +* +* Recompute NBNEXT in case 2 by 2 split +* + IF( T( HERE, HERE-1 ).EQ.ZERO ) + $ NBNEXT = 1 + IF( NBNEXT.EQ.2 ) THEN +* +* 2 by 2 Block did not split +* + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 2, 1, + $ WORK, INFO ) + IF( INFO.NE.0 ) THEN + ILST = HERE + RETURN + END IF + HERE = HERE - 2 + ELSE +* +* 2 by 2 Block did split +* + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, + $ WORK, INFO ) + CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 1, 1, + $ WORK, INFO ) + HERE = HERE - 2 + END IF + END IF + END IF + IF( HERE.GT.ILST ) + $ GO TO 20 + END IF + ILST = HERE +* + RETURN +* +* End of DTREXC +* + END -\end{chunk} +\end{verbatim} \begin{chunk}{LAPACK dtrexc} (let* ((zero 0.0)) @@ -74076,151 +104612,504 @@ SYNOPSIS DOUBLE PRECISION S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), WORK( LDWORK, * ) -PURPOSE - DTRSNA estimates reciprocal condition numbers for specified eigenvalues - and/or right eigenvectors of a real upper quasi-triangular matrix T (or - of any matrix Q*T*Q**T with Q orthogonal). + Purpose + ======= + + DTRSNA estimates reciprocal condition numbers for specified + eigenvalues and/or right eigenvectors of a real upper + quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q + orthogonal). + + T must be in Schur canonical form (as returned by DHSEQR), that is, + block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each + 2-by-2 diagonal block has its diagonal elements equal and its + off-diagonal elements of opposite sign. + + Arguments + ========= + + JOB (input) CHARACTER*1 + Specifies whether condition numbers are required for + eigenvalues (S) or eigenvectors (SEP): + = 'E': for eigenvalues only (S); + = 'V': for eigenvectors only (SEP); + = 'B': for both eigenvalues and eigenvectors (S and SEP). + + HOWMNY (input) CHARACTER*1 + = 'A': compute condition numbers for all eigenpairs; + = 'S': compute condition numbers for selected eigenpairs + specified by the array SELECT. + + SELECT (input) LOGICAL array, dimension (N) + If HOWMNY = 'S', SELECT specifies the eigenpairs for which + condition numbers are required. To select condition numbers + for the eigenpair corresponding to a real eigenvalue w(j), + SELECT(j) must be set to .TRUE.. To select condition numbers + corresponding to a complex conjugate pair of eigenvalues w(j) + and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be + set to .TRUE.. + If HOWMNY = 'A', SELECT is not referenced. + + N (input) INTEGER + The order of the matrix T. N >= 0. + + T (input) DOUBLE PRECISION array, dimension (LDT,N) + The upper quasi-triangular matrix T, in Schur canonical form. + + LDT (input) INTEGER + The leading dimension of the array T. LDT >= max(1,N). + + VL (input) DOUBLE PRECISION array, dimension (LDVL,M) + If JOB = 'E' or 'B', VL must contain left eigenvectors of T + (or of any Q*T*Q**T with Q orthogonal), corresponding to the + eigenpairs specified by HOWMNY and SELECT. The eigenvectors + must be stored in consecutive columns of VL, as returned by + DHSEIN or DTREVC. + If JOB = 'V', VL is not referenced. + + LDVL (input) INTEGER + The leading dimension of the array VL. + LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N. + + VR (input) DOUBLE PRECISION array, dimension (LDVR,M) + If JOB = 'E' or 'B', VR must contain right eigenvectors of T + (or of any Q*T*Q**T with Q orthogonal), corresponding to the + eigenpairs specified by HOWMNY and SELECT. The eigenvectors + must be stored in consecutive columns of VR, as returned by + DHSEIN or DTREVC. + If JOB = 'V', VR is not referenced. + + LDVR (input) INTEGER + The leading dimension of the array VR. + LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N. + + S (output) DOUBLE PRECISION array, dimension (MM) + If JOB = 'E' or 'B', the reciprocal condition numbers of the + selected eigenvalues, stored in consecutive elements of the + array. For a complex conjugate pair of eigenvalues two + consecutive elements of S are set to the same value. Thus + S(j), SEP(j), and the j-th columns of VL and VR all + correspond to the same eigenpair (but not in general the + j-th eigenpair, unless all eigenpairs are selected). + If JOB = 'V', S is not referenced. + + SEP (output) DOUBLE PRECISION array, dimension (MM) + If JOB = 'V' or 'B', the estimated reciprocal condition + numbers of the selected eigenvectors, stored in consecutive + elements of the array. For a complex eigenvector two + consecutive elements of SEP are set to the same value. If + the eigenvalues cannot be reordered to compute SEP(j), SEP(j) + is set to 0; this can only occur when the true value would be + very small anyway. + If JOB = 'E', SEP is not referenced. + + MM (input) INTEGER + The number of elements in the arrays S (if JOB = 'E' or 'B') + and/or SEP (if JOB = 'V' or 'B'). MM >= M. + + M (output) INTEGER + The number of elements of the arrays S and/or SEP actually + used to store the estimated condition numbers. + If HOWMNY = 'A', M is set to N. + + WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+1) + If JOB = 'E', WORK is not referenced. + + LDWORK (input) INTEGER + The leading dimension of the array WORK. + LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N. + + IWORK (workspace) INTEGER array, dimension (N) + If JOB = 'E', IWORK is not referenced. + + INFO (output) INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value + + Further Details + =============== + + The reciprocal of the condition number of an eigenvalue lambda is + defined as + + S(lambda) = |v'*u| / (norm(u)*norm(v)) + + where u and v are the right and left eigenvectors of T corresponding + to lambda; v' denotes the conjugate-transpose of v, and norm(u) + denotes the Euclidean norm. These reciprocal condition numbers always + lie between zero (very badly conditioned) and one (very well + conditioned). If n = 1, S(lambda) is defined to be 1. - T must be in Schur canonical form (as returned by DHSEQR), that is, - block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each - 2-by-2 diagonal block has its diagonal elements equal and its off-diag- - onal elements of opposite sign. + An approximate error bound for a computed eigenvalue W(i) is given by + + EPS * norm(T) / S(i) + where EPS is the machine precision. -ARGUMENTS - JOB (input) CHARACTER*1 - Specifies whether condition numbers are required for eigenval- - ues (S) or eigenvectors (SEP): - = 'E': for eigenvalues only (S); - = 'V': for eigenvectors only (SEP); - = 'B': for both eigenvalues and eigenvectors (S and SEP). - - HOWMNY (input) CHARACTER*1 - = 'A': compute condition numbers for all eigenpairs; - = 'S': compute condition numbers for selected eigenpairs speci- - fied by the array SELECT. - - SELECT (input) LOGICAL array, dimension (N) - If HOWMNY = 'S', SELECT specifies the eigenpairs for which con- - dition numbers are required. To select condition numbers for - the eigenpair corresponding to a real eigenvalue w(j), - SELECT(j) must be set to .TRUE.. To select condition numbers - corresponding to a complex conjugate pair of eigenvalues w(j) - and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be - set to .TRUE.. If HOWMNY = 'A', SELECT is not referenced. + The reciprocal of the condition number of the right eigenvector u + corresponding to lambda is defined as follows. Suppose - N (input) INTEGER - The order of the matrix T. N >= 0. + T = ( lambda c ) + ( 0 T22 ) - T (input) DOUBLE PRECISION array, dimension (LDT,N) - The upper quasi-triangular matrix T, in Schur canonical form. + Then the reciprocal condition number is - LDT (input) INTEGER - The leading dimension of the array T. LDT >= max(1,N). + SEP( lambda, T22 ) = sigma-min( T22 - lambda*I ) - VL (input) DOUBLE PRECISION array, dimension (LDVL,M) - If JOB = 'E' or 'B', VL must contain left eigenvectors of T (or - of any Q*T*Q**T with Q orthogonal), corresponding to the eigen- - pairs specified by HOWMNY and SELECT. The eigenvectors must be - stored in consecutive columns of VL, as returned by DHSEIN or - DTREVC. If JOB = 'V', VL is not referenced. + where sigma-min denotes the smallest singular value. We approximate + the smallest singular value by the reciprocal of an estimate of the + one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is + defined to be abs(T(1,1)). - LDVL (input) INTEGER - The leading dimension of the array VL. LDVL >= 1; and if JOB = - 'E' or 'B', LDVL >= N. - - VR (input) DOUBLE PRECISION array, dimension (LDVR,M) - If JOB = 'E' or 'B', VR must contain right eigenvectors of T - (or of any Q*T*Q**T with Q orthogonal), corresponding to the - eigenpairs specified by HOWMNY and SELECT. The eigenvectors - must be stored in consecutive columns of VR, as returned by - DHSEIN or DTREVC. If JOB = 'V', VR is not referenced. - - LDVR (input) INTEGER - The leading dimension of the array VR. LDVR >= 1; and if JOB = - 'E' or 'B', LDVR >= N. - - S (output) DOUBLE PRECISION array, dimension (MM) - If JOB = 'E' or 'B', the reciprocal condition numbers of the - selected eigenvalues, stored in consecutive elements of the - array. For a complex conjugate pair of eigenvalues two consecu- - tive elements of S are set to the same value. Thus S(j), - SEP(j), and the j-th columns of VL and VR all correspond to the - same eigenpair (but not in general the j-th eigenpair, unless - all eigenpairs are selected). If JOB = 'V', S is not refer- - enced. - - SEP (output) DOUBLE PRECISION array, dimension (MM) - If JOB = 'V' or 'B', the estimated reciprocal condition numbers - of the selected eigenvectors, stored in consecutive elements of - the array. For a complex eigenvector two consecutive elements - of SEP are set to the same value. If the eigenvalues cannot be - reordered to compute SEP(j), SEP(j) is set to 0; this can only - occur when the true value would be very small anyway. If JOB = - 'E', SEP is not referenced. - - MM (input) INTEGER - The number of elements in the arrays S (if JOB = 'E' or 'B') - and/or SEP (if JOB = 'V' or 'B'). MM >= M. - - M (output) INTEGER - The number of elements of the arrays S and/or SEP actually used - to store the estimated condition numbers. If HOWMNY = 'A', M - is set to N. - - WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+6) - If JOB = 'E', WORK is not referenced. - - LDWORK (input) INTEGER - The leading dimension of the array WORK. LDWORK >= 1; and if - JOB = 'V' or 'B', LDWORK >= N. - - IWORK (workspace) INTEGER array, dimension (2*(N-1)) - If JOB = 'E', IWORK is not referenced. - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - -FURTHER DETAILS - The reciprocal of the condition number of an eigenvalue lambda is - defined as + An approximate error bound for a computed right eigenvector VR(i) + is given by - S(lambda) = |v'*u| / (norm(u)*norm(v)) + EPS * norm(T) / SEP(i) - where u and v are the right and left eigenvectors of T corresponding to - lambda; v' denotes the conjugate-transpose of v, and norm(u) denotes - the Euclidean norm. These reciprocal condition numbers always lie - between zero (very badly conditioned) and one (very well conditioned). - If n = 1, S(lambda) is defined to be 1. - - An approximate error bound for a computed eigenvalue W(i) is given by - - EPS * norm(T) / S(i) - - where EPS is the machine precision. - - The reciprocal of the condition number of the right eigenvector u cor- - responding to lambda is defined as follows. Suppose - - T = ( lambda c ) - ( 0 T22 ) - - Then the reciprocal condition number is - - SEP( lambda, T22 ) = sigma-min( T22 - lambda*I ) - - where sigma-min denotes the smallest singular value. We approximate the - smallest singular value by the reciprocal of an estimate of the one- - norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is defined to - be abs(T(1,1)). - - An approximate error bound for a computed right eigenvector VR(i) is - given by +\end{chunk} - EPS * norm(T) / SEP(i) +\begin{verbatim} + SUBROUTINE DTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, + $ LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, + $ 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 HOWMNY, JOB + INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ), + $ VR( LDVR, * ), WORK( LDWORK, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL PAIR, SOMCON, WANTBH, WANTS, WANTSP + INTEGER I, IERR, IFST, ILST, J, K, KASE, KS, N2, NN + DOUBLE PRECISION BIGNUM, COND, CS, DELTA, DUMM, EPS, EST, LNRM, + $ MU, PROD, PROD1, PROD2, RNRM, SCALE, SMLNUM, SN +* .. +* .. Local Arrays .. + DOUBLE PRECISION DUMMY( 1 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT, DLAMCH, DLAPY2, DNRM2 + EXTERNAL LSAME, DDOT, DLAMCH, DLAPY2, DNRM2 +* .. +* .. External Subroutines .. + EXTERNAL DLACON, DLACPY, DLAQTR, DTREXC, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + WANTBH = LSAME( JOB, 'B' ) + WANTS = LSAME( JOB, 'E' ) .OR. WANTBH + WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH +* + SOMCON = LSAME( HOWMNY, 'S' ) +* + INFO = 0 + IF( .NOT.WANTS .AND. .NOT.WANTSP ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDVL.LT.1 .OR. ( WANTS .AND. LDVL.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDVR.LT.1 .OR. ( WANTS .AND. LDVR.LT.N ) ) THEN + INFO = -10 + ELSE +* +* Set M to the number of eigenpairs for which condition numbers +* are required, and test MM. +* + IF( SOMCON ) THEN + M = 0 + PAIR = .FALSE. + DO 10 K = 1, N + IF( PAIR ) THEN + PAIR = .FALSE. + ELSE + IF( K.LT.N ) THEN + IF( T( K+1, K ).EQ.ZERO ) THEN + IF( SELECT( K ) ) + $ M = M + 1 + ELSE + PAIR = .TRUE. + IF( SELECT( K ) .OR. SELECT( K+1 ) ) + $ M = M + 2 + END IF + ELSE + IF( SELECT( N ) ) + $ M = M + 1 + END IF + END IF + 10 CONTINUE + ELSE + M = N + END IF +* + IF( MM.LT.M ) THEN + INFO = -13 + ELSE IF( LDWORK.LT.1 .OR. ( WANTSP .AND. LDWORK.LT.N ) ) THEN + INFO = -16 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTRSNA', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( SOMCON ) THEN + IF( .NOT.SELECT( 1 ) ) + $ RETURN + END IF + IF( WANTS ) + $ S( 1 ) = ONE + IF( WANTSP ) + $ SEP( 1 ) = ABS( T( 1, 1 ) ) + RETURN + END IF +* +* Get machine constants +* + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +* + KS = 0 + PAIR = .FALSE. + DO 60 K = 1, N +* +* Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block. +* + IF( PAIR ) THEN + PAIR = .FALSE. + GO TO 60 + ELSE + IF( K.LT.N ) + $ PAIR = T( K+1, K ).NE.ZERO + END IF +* +* Determine whether condition numbers are required for the k-th +* eigenpair. +* + IF( SOMCON ) THEN + IF( PAIR ) THEN + IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) ) + $ GO TO 60 + ELSE + IF( .NOT.SELECT( K ) ) + $ GO TO 60 + END IF + END IF +* + KS = KS + 1 +* + IF( WANTS ) THEN +* +* Compute the reciprocal condition number of the k-th +* eigenvalue. +* + IF( .NOT.PAIR ) THEN +* +* Real eigenvalue. +* + PROD = DDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 ) + RNRM = DNRM2( N, VR( 1, KS ), 1 ) + LNRM = DNRM2( N, VL( 1, KS ), 1 ) + S( KS ) = ABS( PROD ) / ( RNRM*LNRM ) + ELSE +* +* Complex eigenvalue. +* + PROD1 = DDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 ) + PROD1 = PROD1 + DDOT( N, VR( 1, KS+1 ), 1, VL( 1, KS+1 ), + $ 1 ) + PROD2 = DDOT( N, VL( 1, KS ), 1, VR( 1, KS+1 ), 1 ) + PROD2 = PROD2 - DDOT( N, VL( 1, KS+1 ), 1, VR( 1, KS ), + $ 1 ) + RNRM = DLAPY2( DNRM2( N, VR( 1, KS ), 1 ), + $ DNRM2( N, VR( 1, KS+1 ), 1 ) ) + LNRM = DLAPY2( DNRM2( N, VL( 1, KS ), 1 ), + $ DNRM2( N, VL( 1, KS+1 ), 1 ) ) + COND = DLAPY2( PROD1, PROD2 ) / ( RNRM*LNRM ) + S( KS ) = COND + S( KS+1 ) = COND + END IF + END IF +* + IF( WANTSP ) THEN +* +* Estimate the reciprocal condition number of the k-th +* eigenvector. +* +* Copy the matrix T to the array WORK and swap the diagonal +* block beginning at T(k,k) to the (1,1) position. +* + CALL DLACPY( 'Full', N, N, T, LDT, WORK, LDWORK ) + IFST = K + ILST = 1 + CALL DTREXC( 'No Q', N, WORK, LDWORK, DUMMY, 1, IFST, ILST, + $ WORK( 1, N+1 ), IERR ) +* + IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN +* +* Could not swap because blocks not well separated +* + SCALE = ONE + EST = BIGNUM + ELSE +* +* Reordering successful +* + IF( WORK( 2, 1 ).EQ.ZERO ) THEN +* +* Form C = T22 - lambda*I in WORK(2:N,2:N). +* + DO 20 I = 2, N + WORK( I, I ) = WORK( I, I ) - WORK( 1, 1 ) + 20 CONTINUE + N2 = 1 + NN = N - 1 + ELSE +* +* Triangularize the 2 by 2 block by unitary +* transformation U = [ cs i*ss ] +* [ i*ss cs ]. +* such that the (1,1) position of WORK is complex +* eigenvalue lambda with positive imaginary part. (2,2) +* position of WORK is the complex eigenvalue lambda +* with negative imaginary part. +* + MU = SQRT( ABS( WORK( 1, 2 ) ) )* + $ SQRT( ABS( WORK( 2, 1 ) ) ) + DELTA = DLAPY2( MU, WORK( 2, 1 ) ) + CS = MU / DELTA + SN = -WORK( 2, 1 ) / DELTA +* +* Form +* +* C' = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ] +* [ mu ] +* [ .. ] +* [ .. ] +* [ mu ] +* where C' is conjugate transpose of complex matrix C, +* and RWORK is stored starting in the N+1-st column of +* WORK. +* + DO 30 J = 3, N + WORK( 2, J ) = CS*WORK( 2, J ) + WORK( J, J ) = WORK( J, J ) - WORK( 1, 1 ) + 30 CONTINUE + WORK( 2, 2 ) = ZERO +* + WORK( 1, N+1 ) = TWO*MU + DO 40 I = 2, N - 1 + WORK( I, N+1 ) = SN*WORK( 1, I+1 ) + 40 CONTINUE + N2 = 2 + NN = 2*( N-1 ) + END IF +* +* Estimate norm(inv(C')) +* + EST = ZERO + KASE = 0 + 50 CONTINUE + CALL DLACON( NN, WORK( 1, N+2 ), WORK( 1, N+4 ), IWORK, + $ EST, KASE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.1 ) THEN + IF( N2.EQ.1 ) THEN +* +* Real eigenvalue: solve C'*x = scale*c. +* + CALL DLAQTR( .TRUE., .TRUE., N-1, WORK( 2, 2 ), + $ LDWORK, DUMMY, DUMM, SCALE, + $ WORK( 1, N+4 ), WORK( 1, N+6 ), + $ IERR ) + ELSE +* +* Complex eigenvalue: solve +* C'*(p+iq) = scale*(c+id) in real arithmetic. +* + CALL DLAQTR( .TRUE., .FALSE., N-1, WORK( 2, 2 ), + $ LDWORK, WORK( 1, N+1 ), MU, SCALE, + $ WORK( 1, N+4 ), WORK( 1, N+6 ), + $ IERR ) + END IF + ELSE + IF( N2.EQ.1 ) THEN +* +* Real eigenvalue: solve C*x = scale*c. +* + CALL DLAQTR( .FALSE., .TRUE., N-1, WORK( 2, 2 ), + $ LDWORK, DUMMY, DUMM, SCALE, + $ WORK( 1, N+4 ), WORK( 1, N+6 ), + $ IERR ) + ELSE +* +* Complex eigenvalue: solve +* C*(p+iq) = scale*(c+id) in real arithmetic. +* + CALL DLAQTR( .FALSE., .FALSE., N-1, + $ WORK( 2, 2 ), LDWORK, + $ WORK( 1, N+1 ), MU, SCALE, + $ WORK( 1, N+4 ), WORK( 1, N+6 ), + $ IERR ) +* + END IF + END IF +* + GO TO 50 + END IF + END IF +* + SEP( KS ) = SCALE / MAX( EST, SMLNUM ) + IF( PAIR ) + $ SEP( KS+1 ) = SEP( KS ) + END IF +* + IF( PAIR ) + $ KS = KS + 1 +* + 60 CONTINUE + RETURN +* +* End of DTRSNA +* + END -\end{chunk} +\end{verbatim} \begin{chunk}{LAPACK dtrsna} (let* ((zero 0.0) (one 1.0) (two 2.0)) @@ -74867,35 +105756,159 @@ SYNOPSIS REAL ONE, ZERO -PURPOSE - IEEECK is called from the ILAENV to verify that Infinity and possibly - NaN arithmetic is safe (i.e. will not trap). + Purpose + ======= + IEEECK is called from the ILAENV to verify that Infinity and + possibly NaN arithmetic is safe (i.e. will not trap). -ARGUMENTS - ISPEC (input) INTEGER - Specifies whether to test just for inifinity arithmetic or - whether to test for infinity and NaN arithmetic. = 0: Verify - infinity arithmetic only. - = 1: Verify infinity and NaN arithmetic. + Arguments + ========= - ZERO (input) REAL - Must contain the value 0.0 This is passed to prevent the com- - piler from optimizing away this code. + ISPEC (input) INTEGER + Specifies whether to test just for inifinity arithmetic + or whether to test for infinity and NaN arithmetic. + = 0: Verify infinity arithmetic only. + = 1: Verify infinity and NaN arithmetic. - ONE (input) REAL - Must contain the value 1.0 This is passed to prevent the com- - piler from optimizing away this code. + ZERO (input) REAL + Must contain the value 0.0 + This is passed to prevent the compiler from optimizing + away this code. - RETURN VALUE: INTEGER = 0: Arithmetic failed to produce the - correct answers - = 1: Arithmetic produced the correct answers + ONE (input) REAL + Must contain the value 1.0 + This is passed to prevent the compiler from optimizing + away this code. + RETURN VALUE: INTEGER + = 0: Arithmetic failed to produce the correct answers + = 1: Arithmetic produced the correct answers +\end{chunk} - Return if we were only asked to check infinity arithmetic +\begin{verbatim} + INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* June 30, 1998 +* +* .. Scalar Arguments .. + INTEGER ISPEC + REAL ONE, ZERO +* .. +* +* .. Local Scalars .. + REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, + $ NEGZRO, NEWZRO, POSINF +* .. +* .. Executable Statements .. + IEEECK = 1 +* + POSINF = ONE / ZERO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = -ONE / ZERO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGZRO = ONE / ( NEGINF+ONE ) + IF( NEGZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = ONE / NEGZRO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEWZRO = NEGZRO + ZERO + IF( NEWZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = ONE / NEWZRO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = NEGINF*POSINF + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = POSINF*POSINF + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* +* +* +* +* Return if we were only asked to check infinity arithmetic +* + IF( ISPEC.EQ.0 ) + $ RETURN +* + NAN1 = POSINF + NEGINF +* + NAN2 = POSINF / NEGINF +* + NAN3 = POSINF / POSINF +* + NAN4 = POSINF*ZERO +* + NAN5 = NEGINF*NEGZRO +* + NAN6 = NAN5*0.0 +* + IF( NAN1.EQ.NAN1 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN2.EQ.NAN2 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN3.EQ.NAN3 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN4.EQ.NAN4 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN5.EQ.NAN5 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN6.EQ.NAN6 ) THEN + IEEECK = 0 + RETURN + END IF +* + RETURN + END -\end{chunk} +\end{verbatim} \begin{chunk}{LAPACK ieeeck} (defun ieeeck (ispec zero one) @@ -75018,88 +106031,558 @@ SYNOPSIS INTEGER ISPEC, N1, N2, N3, N4 -PURPOSE - ILAENV is called from the LAPACK routines to choose problem-dependent - parameters for the local environment. See ISPEC for a description of - the parameters. - - ILAENV returns an INTEGER - if ILAENV >= 0: ILAENV returns the value of the parameter specified by - ISPEC if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal - value. - - This version provides a set of parameters which should give good, but - not optimal, performance on many of the currently available computers. - Users are encouraged to modify this subroutine to set the tuning param- - eters for their particular machine using the option and problem size - information in the arguments. - - This routine will not function correctly if it is converted to all - lower case. Converting it to all upper case is allowed. - - -ARGUMENTS - ISPEC (input) INTEGER - Specifies the parameter to be returned as the value of ILAENV. - = 1: the optimal blocksize; if this value is 1, an unblocked - algorithm will give the best performance. = 2: the minimum - block size for which the block routine should be used; if the - usable block size is less than this value, an unblocked routine - should be used. = 3: the crossover point (in a block routine, - for N less than this value, an unblocked routine should be - used) = 4: the number of shifts, used in the nonsymmetric - eigenvalue routines (DEPRECATED) = 5: the minimum column dimen- - sion for blocking to be used; rectangular blocks must have - dimension at least k by m, where k is given by ILAENV(2,...) - and m by ILAENV(5,...) = 6: the crossover point for the SVD - (when reducing an m by n matrix to bidiagonal form, if - max(m,n)/min(m,n) exceeds this value, a QR factorization is - used first to reduce the matrix to a triangular form.) = 7: - the number of processors - = 8: the crossover point for the multishift QR method for non- - symmetric eigenvalue problems (DEPRECATED) = 9: maximum size of - the subproblems at the bottom of the computation tree in the - divide-and-conquer algorithm (used by xGELSD and xGESDD) =10: - ieee NaN arithmetic can be trusted not to trap - =11: infinity arithmetic can be trusted not to trap - 12 <= ISPEC <= 16: xHSEQR or one of its subroutines, see IPARMQ - for detailed explanation - - NAME (input) CHARACTER*(*) - The name of the calling subroutine, in either upper case or - lower case. - - OPTS (input) CHARACTER*(*) - The character options to the subroutine NAME, concatenated into - a single character string. For example, UPLO = 'U', TRANS = - 'T', and DIAG = 'N' for a triangular routine would be specified - as OPTS = 'UTN'. - - N1 (input) INTEGER - N2 (input) INTEGER N3 (input) INTEGER N4 (input) - INTEGER Problem dimensions for the subroutine NAME; these may - not all be required. - -FURTHER DETAILS - The following conventions have been used when calling ILAENV from the - LAPACK routines: - 1) OPTS is a concatenation of all of the character options to - subroutine NAME, in the same order that they appear in the - argument list for NAME, even if they are not used in determining - the value of the parameter specified by ISPEC. - 2) The problem dimensions N1, N2, N3, N4 are specified in the order - that they appear in the argument list for NAME. N1 is used - first, N2 second, and so on, and unused problem dimensions are - passed a value of -1. - 3) The parameter value returned by ILAENV is checked for validity in - the calling subroutine. For example, ILAENV is used to retrieve - the optimal blocksize for STRTRI as follows: + Purpose + ======= + + ILAENV is called from the LAPACK routines to choose problem-dependent + parameters for the local environment. See ISPEC for a description of + the parameters. + + This version provides a set of parameters which should give good, + but not optimal, performance on many of the currently available + computers. Users are encouraged to modify this subroutine to set + the tuning parameters for their particular machine using the option + and problem size information in the arguments. + + This routine will not function correctly if it is converted to all + lower case. Converting it to all upper case is allowed. + + Arguments + ========= + + ISPEC (input) INTEGER + Specifies the parameter to be returned as the value of + ILAENV. + = 1: the optimal blocksize; if this value is 1, an unblocked + algorithm will give the best performance. + = 2: the minimum block size for which the block routine + should be used; if the usable block size is less than + this value, an unblocked routine should be used. + = 3: the crossover point (in a block routine, for N less + than this value, an unblocked routine should be used) + = 4: the number of shifts, used in the nonsymmetric + eigenvalue routines + = 5: the minimum column dimension for blocking to be used; + rectangular blocks must have dimension at least k by m, + where k is given by ILAENV(2,...) and m by ILAENV(5,...) + = 6: the crossover point for the SVD (when reducing an m by n + matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds + this value, a QR factorization is used first to reduce + the matrix to a triangular form.) + = 7: the number of processors + = 8: the crossover point for the multishift QR and QZ methods + for nonsymmetric eigenvalue problems. + = 9: maximum size of the subproblems at the bottom of the + computation tree in the divide-and-conquer algorithm + (used by xGELSD and xGESDD) + =10: ieee NaN arithmetic can be trusted not to trap + =11: infinity arithmetic can be trusted not to trap + + NAME (input) CHARACTER*(*) + The name of the calling subroutine, in either upper case or + lower case. + + OPTS (input) CHARACTER*(*) + The character options to the subroutine NAME, concatenated + into a single character string. For example, UPLO = 'U', + TRANS = 'T', and DIAG = 'N' for a triangular routine would + be specified as OPTS = 'UTN'. + + N1 (input) INTEGER + N2 (input) INTEGER + N3 (input) INTEGER + N4 (input) INTEGER + Problem dimensions for the subroutine NAME; these may not all + be required. + + (ILAENV) (output) INTEGER + >= 0: the value of the parameter specified by ISPEC + < 0: if ILAENV = -k, the k-th argument had an illegal value. + + Further Details + =============== + + The following conventions have been used when calling ILAENV from the + LAPACK routines: + 1) OPTS is a concatenation of all of the character options to + subroutine NAME, in the same order that they appear in the + argument list for NAME, even if they are not used in determining + the value of the parameter specified by ISPEC. + 2) The problem dimensions N1, N2, N3, N4 are specified in the order + that they appear in the argument list for NAME. N1 is used + first, N2 second, and so on, and unused problem dimensions are + passed a value of -1. + 3) The parameter value returned by ILAENV is checked for validity in + the calling subroutine. For example, ILAENV is used to retrieve + the optimal blocksize for STRTRI as follows: + + NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) + IF( NB.LE.1 ) NB = MAX( 1, N ) - NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) - IF( NB.LE.1 ) NB = MAX( 1, N ) +\end{chunk} +\begin{verbatim} + INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, + $ N4 ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* June 30, 1999 +* +* .. Scalar Arguments .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL CNAME, SNAME + CHARACTER*1 C1 + CHARACTER*2 C2, C4 + CHARACTER*3 C3 + CHARACTER*6 SUBNAM + INTEGER I, IC, IZ, NB, NBMIN, NX +* .. +* .. Intrinsic Functions .. + INTRINSIC CHAR, ICHAR, INT, MIN, REAL +* .. +* .. External Functions .. + INTEGER IEEECK + EXTERNAL IEEECK +* .. +* .. Executable Statements .. +* + GO TO ( 100, 100, 100, 400, 500, 600, 700, 800, 900, 1000, + $ 1100 ) ISPEC +* +* Invalid value for ISPEC +* + ILAENV = -1 + RETURN +* + 100 CONTINUE +* +* Convert NAME to upper case if the first character is lower case. +* + ILAENV = 1 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1:1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1:1 ) = CHAR( IC-32 ) + DO 10 I = 2, 6 + IC = ICHAR( SUBNAM( I:I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I:I ) = CHAR( IC-32 ) + 10 CONTINUE + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1:1 ) = CHAR( IC+64 ) + DO 20 I = 2, 6 + IC = ICHAR( SUBNAM( I:I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) + $ SUBNAM( I:I ) = CHAR( IC+64 ) + 20 CONTINUE + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1:1 ) = CHAR( IC-32 ) + DO 30 I = 2, 6 + IC = ICHAR( SUBNAM( I:I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I:I ) = CHAR( IC-32 ) + 30 CONTINUE + END IF + END IF +* + C1 = SUBNAM( 1:1 ) + SNAME = C1.EQ.'S' .OR. C1.EQ.'D' + CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' + IF( .NOT.( CNAME .OR. SNAME ) ) + $ RETURN + C2 = SUBNAM( 2:3 ) + C3 = SUBNAM( 4:6 ) + C4 = C3( 2:3 ) +* + GO TO ( 110, 200, 300 ) ISPEC +* + 110 CONTINUE +* +* ISPEC = 1: block size +* +* In these examples, separate code is provided for setting NB for +* real and complex. We assume that NB will take the same value in +* single or double precision. +* + NB = 1 +* + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'PO' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRF' ) THEN + NB = 64 + ELSE IF( C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1:1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NB = 32 + END IF + ELSE IF( C3( 1:1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NB = 32 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1:1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NB = 32 + END IF + ELSE IF( C3( 1:1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NB = 32 + END IF + END IF + ELSE IF( C2.EQ.'GB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'PB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'TR' ) THEN + IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'LA' ) THEN + IF( C3.EQ.'UUM' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN + IF( C3.EQ.'EBZ' ) THEN + NB = 1 + END IF + END IF + ILAENV = NB + RETURN +* + 200 CONTINUE +* +* ISPEC = 2: minimum block size +* + NBMIN = 2 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NBMIN = 8 + ELSE + NBMIN = 8 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1:1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1:1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NBMIN = 2 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1:1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1:1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NBMIN = 2 + END IF + END IF + END IF + ILAENV = NBMIN + RETURN +* + 300 CONTINUE +* +* ISPEC = 3: crossover point +* + NX = 0 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1:1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NX = 128 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1:1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NX = 128 + END IF + END IF + END IF + ILAENV = NX + RETURN +* + 400 CONTINUE +* +* ISPEC = 4: number of shifts (used by xHSEQR) +* + ILAENV = 6 + RETURN +* + 500 CONTINUE +* +* ISPEC = 5: minimum column dimension (not used) +* + ILAENV = 2 + RETURN +* + 600 CONTINUE +* +* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) +* + ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) + RETURN +* + 700 CONTINUE +* +* ISPEC = 7: number of processors (not used) +* + ILAENV = 1 + RETURN +* + 800 CONTINUE +* +* ISPEC = 8: crossover point for multishift (used by xHSEQR) +* + ILAENV = 50 + RETURN +* + 900 CONTINUE +* +* ISPEC = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* + ILAENV = 25 + RETURN +* + 1000 CONTINUE +* +* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap +* +C ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 0, 0.0, 1.0 ) + END IF + RETURN +* + 1100 CONTINUE +* +* ISPEC = 11: infinity arithmetic can be trusted not to trap +* +C ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 1, 0.0, 1.0 ) + END IF + RETURN +* +* End of ILAENV +* + END -\end{chunk} +\end{verbatim} \begin{chunk}{LAPACK ilaenv} (defun ilaenv (ispec name opts n1 n2 n3 n4) @@ -75548,14 +107031,14 @@ FURTHER DETAILS \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zlange LAPACK} -%\pagehead{zlange}{zlange} +\section{ilazlc LAPACK} +%\pagehead{ilazlc}{ilazlc} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} -\begin{chunk}{zlange.input} +\begin{chunk}{ilazlc.input} )set break resume -)sys rm -f zlange.output -)spool zlange.output +)sys rm -f ilazlc.output +)spool ilazlc.output )set message test on )set message auto off )clear all @@ -75563,194 +107046,260 @@ FURTHER DETAILS )spool )lisp (bye) \end{chunk} -\begin{chunk}{zlange.help} +\begin{chunk}{ilazlc.help} ==================================================================== -zlange examples +ilazlc examples ==================================================================== ==================================================================== Man Page Details ==================================================================== -NAME - ZLANGE - the value of the one norm, or the Frobenius norm, or the - infinity norm, or the element of largest absolute value of a complex - matrix A + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ -SYNOPSIS - DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) + Definition: + =========== - CHARACTER NORM + INTEGER FUNCTION ILAZLC( M, N, A, LDA ) + + .. Scalar Arguments .. + INTEGER M, N, LDA + .. + .. Array Arguments .. + COMPLEX*16 A( LDA, * ) + .. + - INTEGER LDA, M, N + Purpose: + ============= - DOUBLE PRECISION WORK( * ) + ILAZLC scans A for its last non-zero column. - COMPLEX*16 A( LDA, * ) + Arguments: + ========== -PURPOSE - ZLANGE returns the value of the one norm, or the Frobenius norm, or - the infinity norm, or the element of largest absolute value of a - complex matrix A. + [in] M + M is INTEGER + The number of rows of the matrix A. + [in] N + N is INTEGER + The number of columns of the matrix A. -DESCRIPTION - ZLANGE returns the value + [in] A + A is COMPLEX*16 array, dimension (LDA,N) + The m by n matrix A. - ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' - ( - ( norm1(A), NORM = '1', 'O' or 'o' - ( - ( normI(A), NORM = 'I' or 'i' - ( - ( normF(A), NORM = 'F', 'f', 'E' or 'e' + [in] LDA + LDA is INTEGER + The leading dimension of the array A. LDA >= max(1,M). - where norm1 denotes the one norm of a matrix (maximum column sum), - normI denotes the infinity norm of a matrix (maximum row sum) and - normF denotes the Frobenius norm of a matrix (square root of sum of - squares). Note that max(abs(A(i,j))) is not a consistent matrix - norm. + Authors: + ======== + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. -ARGUMENTS - NORM (input) CHARACTER*1 - Specifies the value to be returned in ZLANGE as described - above. + November 2011 - M (input) INTEGER - The number of rows of the matrix A. M >= 0. When M = 0, - ZLANGE is set to zero. +\end{chunk} - N (input) INTEGER - The number of columns of the matrix A. N >= 0. When N = 0, - ZLANGE is set to zero. +\begin{verbatim} +* ===================================================================== + INTEGER FUNCTION ILAZLC( M, N, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = (0.0D+0, 0.0D+0) ) +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( N.EQ.0 ) THEN + ILAZLC = N + ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILAZLC = N + ELSE +* Now scan each column from the end, returning with the first non-zero. + DO ILAZLC = N, 1, -1 + DO I = 1, M + IF( A(I, ILAZLC).NE.ZERO ) RETURN + END DO + END DO + END IF + RETURN + END - A (input) COMPLEX*16 array, dimension (LDA,N) - The m by n matrix A. +\end{verbatim} - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(M,1). +\begin{chunk}{LAPACK ilazlc} - WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), - where LWORK >= M when NORM = 'I'; otherwise, WORK is not refer- - enced. +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ilazlr LAPACK} +%\pagehead{ilazlr}{ilazlr} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} +\begin{chunk}{ilazlr.input} +)set break resume +)sys rm -f ilazlr.output +)spool ilazlr.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) \end{chunk} +\begin{chunk}{ilazlr.help} +==================================================================== +ilazlr examples +==================================================================== -\begin{chunk}{LAPACK zlange} -(let* ((one 1.0) (zero 0.0)) - (declare (type (double-float 1.0 1.0) one) - (type (double-float 0.0 0.0) zero)) - (defun zlange (norm m n a lda work) - (declare (type (simple-array double-float (*)) work) - (type (simple-array (complex double-float) (*)) a) - (type fixnum lda n m) - (type character norm)) - (f2cl-lib:with-multi-array-data - ((norm character norm-%data% norm-%offset%) - (a (complex double-float) a-%data% a-%offset%) - (work double-float work-%data% work-%offset%)) - (prog ((scale 0.0) (sum 0.0) (value 0.0) (i 0) (j 0) (zlange 0.0)) - (declare (type fixnum i j) - (type (double-float) scale sum value zlange)) - (cond - ((= (min (the fixnum m) (the fixnum n)) 0) - (setf value zero)) - ((char-equal norm #\M) - (setf value zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf value - (max value - (abs - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%))))))))) - ((or (char-equal norm #\O) (f2cl-lib:fstring-= norm "1")) - (setf value zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf sum zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf sum - (+ sum - (abs - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))))) - (setf value (max value sum))))) - ((char-equal norm #\I) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) - zero))) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) - (+ - (f2cl-lib:fref work-%data% - (i) - ((1 *)) - work-%offset%) - (abs - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))))))) - (setf value zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf value - (max value - (f2cl-lib:fref work-%data% - (i) - ((1 *)) - work-%offset%)))))) - ((or (char-equal norm #\F) (char-equal norm #\E)) - (setf scale zero) - (setf sum one) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) - (zlassq m - (f2cl-lib:array-slice a - (complex double-float) - (1 j) - ((1 lda) (1 *))) - 1 scale sum) - (declare (ignore var-0 var-1 var-2)) - (setf scale var-3) - (setf sum var-4)))) - (setf value (* scale (f2cl-lib:fsqrt sum))))) - (setf zlange value) - (return (values zlange nil nil nil nil nil nil)))))) +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + INTEGER FUNCTION ILAZLR( M, N, A, LDA ) + + .. Scalar Arguments .. + INTEGER M, N, LDA + .. + .. Array Arguments .. + COMPLEX*16 A( LDA, * ) + .. + + + Purpose: + ============= + + ILAZLR scans A for its last non-zero row. + + Arguments: + ========== + + [in] M + + M is INTEGER + The number of rows of the matrix A. + + [in] N + N is INTEGER + The number of columns of the matrix A. + + [in] A + + A is COMPLEX*16 array, dimension (LDA,N) + The m by n matrix A. + + [in] LDA + + LDA is INTEGER + The leading dimension of the array A. LDA >= max(1,M). + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + INTEGER FUNCTION ILAZLR( M, N, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER M, N, LDA +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = (0.0D+0, 0.0D+0) ) +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* +* Quick test for the common case where one corner is non-zero. + IF( M.EQ.0 ) THEN + ILAZLR = M + ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN + ILAZLR = M + ELSE +* Scan up each column tracking the last zero row seen. + ILAZLR = 0 + DO J = 1, N + I=M + DO WHILE ((A(I,J).NE.ZERO).AND.(I.GE.1)) + I=I-1 + IF (I.EQ.0) THEN + EXIT + END IF + ENDDO + ILAZLR = MAX( ILAZLR, I ) + END DO + END IF + RETURN + END + +\end{verbatim} + +\begin{chunk}{LAPACK ilazlr} \end{chunk} + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zlassq LAPACK} -%\pagehead{zlassq}{zlassq} +\section{zgebak LAPACK} +%\pagehead{zgebak}{zgebak} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} -\begin{chunk}{zlassq.input} +\begin{chunk}{zgebak.input} )set break resume -)sys rm -f zlassq.output -)spool zlassq.output +)sys rm -f zgebak.output +)spool zgebak.output )set message test on )set message auto off )clear all @@ -75758,118 +107307,14418 @@ ARGUMENTS )spool )lisp (bye) \end{chunk} -\begin{chunk}{zlassq.help} +\begin{chunk}{zgebak.help} ==================================================================== -zlassq examples +zgebak examples ==================================================================== ==================================================================== Man Page Details ==================================================================== -NAME - ZLASSQ - the values scl and ssq such that ( scl**2 )*ssq = x( 1 )**2 - +...+ x( n )**2 + ( scale**2 )*sumsq, + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ -SYNOPSIS - SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) + Definition: + =========== - INTEGER INCX, N + SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, + INFO ) + + .. Scalar Arguments .. + CHARACTER JOB, SIDE + INTEGER IHI, ILO, INFO, LDV, M, N + .. + .. Array Arguments .. + DOUBLE PRECISION SCALE( * ) + COMPLEX*16 V( LDV, * ) + .. + - DOUBLE PRECISION SCALE, SUMSQ + Purpose: + ============= - COMPLEX*16 X( * ) + ZGEBAK forms the right or left eigenvectors of a complex general + matrix by backward transformation on the computed eigenvectors of the + balanced matrix output by ZGEBAL. -PURPOSE - ZLASSQ returns the values scl and ssq such that + Arguments: + ========== - where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is - assumed to be at least unity and the value of ssq will then satisfy + [in] JOB - 1.0 .le. ssq .le. ( sumsq + 2*n ). + JOB is CHARACTER*1 + Specifies the type of backward transformation required: + = 'N', do nothing, return immediately; + = 'P', do backward transformation for permutation only; + = 'S', do backward transformation for scaling only; + = 'B', do backward transformations for both permutation and + scaling. + JOB must be the same as the argument JOB supplied to ZGEBAL. - scale is assumed to be non-negative and scl returns the value + [in] SIDE - scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), - i + SIDE is CHARACTER*1 + = 'R': V contains right eigenvectors; + = 'L': V contains left eigenvectors. - scale and sumsq must be supplied in SCALE and SUMSQ respectively. - SCALE and SUMSQ are overwritten by scl and ssq respectively. + [in] N - The routine makes only one pass through the vector X. + N is INTEGER + The number of rows of the matrix V. N >= 0. + [in] ILO -ARGUMENTS - N (input) INTEGER - The number of elements to be used from the vector X. + ILO is INTEGER + + [in] IHI + + IHI is INTEGER + The integers ILO and IHI determined by ZGEBAL. + 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. + + + [in] SCALE + + SCALE is DOUBLE PRECISION array, dimension (N) + Details of the permutation and scaling factors, as returned + by ZGEBAL. + + + [in] M + + M is INTEGER + The number of columns of the matrix V. M >= 0. + + [in,out] V + + V is COMPLEX*16 array, dimension (LDV,M) + On entry, the matrix of right or left eigenvectors to be + transformed, as returned by ZHSEIN or ZTREVC. + On exit, V is overwritten by the transformed eigenvectors. + + [in] LDV - X (input) COMPLEX*16 array, dimension (N) - The vector x as described above. x( i ) = X( 1 + ( i - 1 - )*INCX ), 1 <= i <= n. + LDV is INTEGER + The leading dimension of the array V. LDV >= max(1,N). - INCX (input) INTEGER - The increment between successive values of the vector X. INCX - > 0. + [out] INFO - SCALE (input/output) DOUBLE PRECISION - On entry, the value scale in the equation above. On exit, - SCALE is overwritten with the value scl . + INFO is INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value. - SUMSQ (input/output) DOUBLE PRECISION - On entry, the value sumsq in the equation above. On exit, - SUMSQ is overwritten with the value ssq . + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 \end{chunk} -\begin{chunk}{LAPACK zlassq} -(let* ((zero 0.0)) - (declare (type (double-float 0.0 0.0) zero)) - (defun zlassq (n x incx scale sumsq) - (declare (type (double-float) sumsq scale) - (type (simple-array (complex double-float) (*)) x) - (type fixnum incx n)) - (f2cl-lib:with-multi-array-data - ((x (complex double-float) x-%data% x-%offset%)) - (prog ((temp1 0.0) (ix 0)) - (declare (type (double-float) temp1) (type fixnum ix)) - (cond - ((> n 0) - (f2cl-lib:fdo (ix 1 (f2cl-lib:int-add ix incx)) - ((> ix - (f2cl-lib:int-add 1 - (f2cl-lib:int-mul - (f2cl-lib:int-add n - (f2cl-lib:int-sub 1)) - incx))) - nil) - (tagbody - (cond - ((/= (coerce (realpart (f2cl-lib:fref x (ix) ((1 *)))) 'double-float) zero) - (setf temp1 - (abs - (coerce (realpart - (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%)) 'double-float))) - (cond - ((< scale temp1) - (setf sumsq (+ 1 (* sumsq (expt (/ scale temp1) 2)))) - (setf scale temp1)) - (t - (setf sumsq (+ sumsq (expt (/ temp1 scale) 2))))))) - (cond - ((/= (f2cl-lib:dimag (f2cl-lib:fref x (ix) ((1 *)))) zero) - (setf temp1 - (abs - (f2cl-lib:dimag - (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%)))) - (cond - ((< scale temp1) - (setf sumsq (+ 1 (* sumsq (expt (/ scale temp1) 2)))) - (setf scale temp1)) - (t - (setf sumsq (+ sumsq (expt (/ temp1 scale) 2))))))))))) - (return (values nil nil nil scale sumsq)))))) +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, + $ INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER JOB, SIDE + INTEGER IHI, ILO, INFO, LDV, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION SCALE( * ) + COMPLEX*16 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 XERBLA, ZDSCAL, ZSWAP +* .. +* .. 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( 'ZGEBAK', -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 ZDSCAL( M, S, V( I, 1 ), LDV ) + 10 CONTINUE + END IF +* + IF( LEFTV ) THEN + DO 20 I = ILO, IHI + S = ONE / SCALE( I ) + CALL ZDSCAL( 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 ZSWAP( 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 ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) + 50 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGEBAK +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zgebak} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zgebal LAPACK} +%\pagehead{zgebal}{zgebal} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zgebal.input} +)set break resume +)sys rm -f zgebal.output +)spool zgebal.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zgebal.help} +==================================================================== +zgebal examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) + + .. Scalar Arguments .. + CHARACTER JOB + INTEGER IHI, ILO, INFO, LDA, N + .. + .. Array Arguments .. + DOUBLE PRECISION SCALE( * ) + COMPLEX*16 A( LDA, * ) + .. + + + Purpose: + ============= + + ZGEBAL balances a general complex matrix A. This involves, first, + permuting A by a similarity transformation to isolate eigenvalues + in the first 1 to ILO-1 and last IHI+1 to N elements on the + diagonal; and second, applying a diagonal similarity transformation + to rows and columns ILO to IHI to make the rows and columns as + close in norm as possible. Both steps are optional. + + Balancing may reduce the 1-norm of the matrix, and improve the + accuracy of the computed eigenvalues and/or eigenvectors. + + Arguments: + ========== + + [in] JOB + + JOB is CHARACTER*1 + Specifies the operations to be performed on A: + = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 + for i = 1,...,N; + = 'P': permute only; + = 'S': scale only; + = 'B': both permute and scale. + + [in] N + + N is INTEGER + The order of the matrix A. N >= 0. + + [in,out] A + + A is COMPLEX*16 array, dimension (LDA,N) + On entry, the input matrix A. + On exit, A is overwritten by the balanced matrix. + If JOB = 'N', A is not referenced. + See Further Details. + + [in] LDA + + LDA is INTEGER + The leading dimension of the array A. LDA >= max(1,N). + + [out] ILO + + [out] IHI + + ILO and IHI are set to INTEGER such that on exit + A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. + If JOB = 'N' or 'S', ILO = 1 and IHI = N. + + [out] SCALE + + SCALE is DOUBLE PRECISION array, dimension (N) + Details of the permutations and scaling factors applied to + A. If P(j) is the index of the row and column interchanged + with row and column j and D(j) is the scaling factor + applied to row and column j, then + SCALE(j) = P(j) for j = 1,...,ILO-1 + = D(j) for j = ILO,...,IHI + = P(j) for j = IHI+1,...,N. + The order in which the interchanges are made is N to IHI+1, + then 1 to ILO-1. + + [out] INFO + + INFO is INTEGER + = 0: successful exit. + < 0: if INFO = -i, the i-th argument had an illegal value. + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + + + Further Details: + ===================== + + The permutations consist of row and column interchanges which put + the matrix in the form + + ( T1 X Y ) + P A P = ( 0 B Z ) + ( 0 0 T2 ) + + where T1 and T2 are upper triangular matrices whose eigenvalues lie + along the diagonal. The column indices ILO and IHI mark the starting + and ending columns of the submatrix B. Balancing consists of applying + a diagonal similarity transformation inv(D) * B * D to make the + 1-norms of each row of B and its corresponding column nearly equal. + The output matrix is + + ( T1 X*D Y ) + ( 0 inv(D)*B*D inv(D)*Z ). + ( 0 0 T2 ) + + Information about the permutations P and the diagonal matrix D is + returned in the vector SCALE. + + This subroutine is based on the EISPACK routine CBAL. + + Modified by Tzu-Yi Chen, Computer Science Division, University of + California at Berkeley, USA + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER JOB + INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION SCALE( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION SCLFAC + PARAMETER ( SCLFAC = 2.0D+0 ) + DOUBLE PRECISION FACTOR + PARAMETER ( FACTOR = 0.95D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOCONV + INTEGER I, ICA, IEXC, IRA, J, K, L, M + DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1, + $ SFMIN2 + COMPLEX*16 CDUM +* .. +* .. External Functions .. + LOGICAL DISNAN, LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL DISNAN, LSAME, IZAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZDSCAL, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. 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( 'ZGEBAL', -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 ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) + CALL ZSWAP( 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( DBLE( A( J, I ) ).NE.ZERO .OR. DIMAG( 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( DBLE( A( I, J ) ).NE.ZERO .OR. DIMAG( 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 + CABS1( A( J, I ) ) + R = R + CABS1( A( I, J ) ) + 150 CONTINUE + ICA = IZAMAX( L, A( 1, I ), 1 ) + CA = ABS( A( ICA, I ) ) + IRA = IZAMAX( N-K+1, A( I, K ), LDA ) + RA = ABS( A( I, IRA+K-1 ) ) +* +* Guard against zero C or R due to underflow. +* + IF( C.EQ.ZERO .OR. R.EQ.ZERO ) + $ GO TO 200 + G = R / SCLFAC + F = ONE + S = C + R + 160 CONTINUE + IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. + $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170 + IF( DISNAN( C+F+CA+R+G+RA ) ) THEN +* +* Exit if NaN to avoid infinite loop +* + INFO = -3 + CALL XERBLA( 'ZGEBAL', -INFO ) + RETURN + END IF + F = F*SCLFAC + C = C*SCLFAC + CA = CA*SCLFAC + R = R / SCLFAC + G = G / SCLFAC + RA = RA / SCLFAC + GO TO 160 +* + 170 CONTINUE + G = C / SCLFAC + 180 CONTINUE + IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. + $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190 + F = F / SCLFAC + C = C / SCLFAC + G = G / SCLFAC + CA = CA / SCLFAC + R = R*SCLFAC + RA = RA*SCLFAC + GO TO 180 +* +* Now balance. +* + 190 CONTINUE + IF( ( C+R ).GE.FACTOR*S ) + $ GO TO 200 + IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN + IF( F*SCALE( I ).LE.SFMIN1 ) + $ GO TO 200 + END IF + IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN + IF( SCALE( I ).GE.SFMAX1 / F ) + $ GO TO 200 + END IF + G = ONE / F + SCALE( I ) = SCALE( I )*F + NOCONV = .TRUE. +* + CALL ZDSCAL( N-K+1, G, A( I, K ), LDA ) + CALL ZDSCAL( L, F, A( 1, I ), 1 ) +* + 200 CONTINUE +* + IF( NOCONV ) + $ GO TO 140 +* + 210 CONTINUE + ILO = K + IHI = L +* + RETURN +* +* End of ZGEBAL +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zgebal} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zgeev LAPACK} +%\pagehead{zgeev}{zgeev} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zgeev.input} +)set break resume +)sys rm -f zgeev.output +)spool zgeev.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zgeev.help} +==================================================================== +zgeev examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + +ZGEEV computes the eigenvalues and, optionally, the left and/or right +eigenvectors for GE matrices + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, + WORK, LWORK, RWORK, INFO ) + + .. Scalar Arguments .. + CHARACTER JOBVL, JOBVR + INTEGER INFO, LDA, LDVL, LDVR, LWORK, N + .. + .. Array Arguments .. + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), + $ W( * ), WORK( * ) + .. + + + Purpose: + ============= + + ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the + eigenvalues and, optionally, the left and/or right eigenvectors. + + The right eigenvector v(j) of A satisfies + A * v(j) = lambda(j) * v(j) + where lambda(j) is its eigenvalue. + The left eigenvector u(j) of A satisfies + u(j)**H * A = lambda(j) * u(j)**H + where u(j)**H denotes the conjugate transpose of u(j). + + The computed eigenvectors are normalized to have Euclidean norm + equal to 1 and largest component real. + + Arguments: + ========== + + [in] JOBVL + + JOBVL is CHARACTER*1 + = 'N': left eigenvectors of A are not computed; + = 'V': left eigenvectors of are computed. + + [in] JOBVR + + JOBVR is CHARACTER*1 + = 'N': right eigenvectors of A are not computed; + = 'V': right eigenvectors of A are computed. + + [in] N + + N is INTEGER + The order of the matrix A. N >= 0. + + [in,out] A + + A is COMPLEX*16 array, dimension (LDA,N) + On entry, the N-by-N matrix A. + On exit, A has been overwritten. + + [in] LDA + + LDA is INTEGER + The leading dimension of the array A. LDA >= max(1,N). + + [out] W + + W is COMPLEX*16 array, dimension (N) + W contains the computed eigenvalues. + + [out] VL + + VL is COMPLEX*16 array, dimension (LDVL,N) + If JOBVL = 'V', the left eigenvectors u(j) are stored one + after another in the columns of VL, in the same order + as their eigenvalues. + If JOBVL = 'N', VL is not referenced. + u(j) = VL(:,j), the j-th column of VL. + + [in] LDVL + + LDVL is INTEGER + The leading dimension of the array VL. LDVL >= 1; if + JOBVL = 'V', LDVL >= N. + + [out] VR + + VR is COMPLEX*16 array, dimension (LDVR,N) + If JOBVR = 'V', the right eigenvectors v(j) are stored one + after another in the columns of VR, in the same order + as their eigenvalues. + If JOBVR = 'N', VR is not referenced. + v(j) = VR(:,j), the j-th column of VR. + + [in] LDVR + + LDVR is INTEGER + The leading dimension of the array VR. LDVR >= 1; if + JOBVR = 'V', LDVR >= N. + + [out] WORK + + WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) + On exit, if INFO = 0, WORK(1) returns the optimal LWORK. + + [in] LWORK + + LWORK is INTEGER + The dimension of the array WORK. LWORK >= max(1,2*N). + For good performance, LWORK must generally be larger. + + If LWORK = -1, then a workspace query is assumed; the routine + only calculates the optimal size of the WORK array, returns + this value as the first entry of the WORK array, and no error + message related to LWORK is issued by XERBLA. + + [out] RWORK + + RWORK is DOUBLE PRECISION array, dimension (2*N) + + [out] INFO + + INFO is INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value. + > 0: if INFO = i, the QR algorithm failed to compute all the + eigenvalues, and no eigenvectors have been computed; + elements and i+1:N of W contain eigenvalues which have + converged. + + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, + $ WORK, LWORK, RWORK, INFO ) +* +* -- LAPACK driver routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER JOBVL, JOBVR + INTEGER INFO, LDA, LDVL, LDVR, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), + $ W( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. 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, IRWORK, ITAU, + $ IWRK, K, MAXWRK, MINWRK, NOUT + DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM + COMPLEX*16 TMP +* .. +* .. Local Arrays .. + LOGICAL SELECT( 1 ) + DOUBLE PRECISION DUM( 1 ) +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD, + $ ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC, ZUNGHR +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DZNRM2, ZLANGE + EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DZNRM2, ZLANGE +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + WANTVL = LSAME( JOBVL, 'V' ) + WANTVR = LSAME( JOBVR, 'V' ) + IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.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. +* CWorkspace refers to complex workspace, and RWorkspace to real +* workspace. NB refers to the optimal block size for the +* immediately following subroutine, as returned by ILAENV. +* HSWORK refers to the workspace preferred by ZHSEQR, as +* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, +* the worst case.) +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + MINWRK = 1 + MAXWRK = 1 + ELSE + MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) + MINWRK = 2*N + IF( WANTVL ) THEN + MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', + $ ' ', N, 1, N, -1 ) ) + CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VL, LDVL, + $ WORK, -1, INFO ) + ELSE IF( WANTVR ) THEN + MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', + $ ' ', N, 1, N, -1 ) ) + CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR, + $ WORK, -1, INFO ) + ELSE + CALL ZHSEQR( 'E', 'N', N, 1, N, A, LDA, W, VR, LDVR, + $ WORK, -1, INFO ) + END IF + HSWORK = WORK( 1 ) + MAXWRK = MAX( MAXWRK, HSWORK, MINWRK ) + END IF + WORK( 1 ) = MAXWRK +* + IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEEV ', -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 = ZLANGE( '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 ZLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) +* +* Balance the matrix +* (CWorkspace: none) +* (RWorkspace: need N) +* + IBAL = 1 + CALL ZGEBAL( 'B', N, A, LDA, ILO, IHI, RWORK( IBAL ), IERR ) +* +* Reduce to upper Hessenberg form +* (CWorkspace: need 2*N, prefer N+N*NB) +* (RWorkspace: none) +* + ITAU = 1 + IWRK = ITAU + N + CALL ZGEHRD( 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 ZLACPY( 'L', N, N, A, LDA, VL, LDVL ) +* +* Generate unitary matrix in VL +* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) +* (RWorkspace: none) +* + CALL ZUNGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) +* +* Perform QR iteration, accumulating Schur vectors in VL +* (CWorkspace: need 1, prefer HSWORK (see comments) ) +* (RWorkspace: none) +* + IWRK = ITAU + CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VL, LDVL, + $ WORK( IWRK ), LWORK-IWRK+1, INFO ) +* + IF( WANTVR ) THEN +* +* Want left and right eigenvectors +* Copy Schur vectors to VR +* + SIDE = 'B' + CALL ZLACPY( 'F', N, N, VL, LDVL, VR, LDVR ) + END IF +* + ELSE IF( WANTVR ) THEN +* +* Want right eigenvectors +* Copy Householder vectors to VR +* + SIDE = 'R' + CALL ZLACPY( 'L', N, N, A, LDA, VR, LDVR ) +* +* Generate unitary matrix in VR +* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) +* (RWorkspace: none) +* + CALL ZUNGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ), + $ LWORK-IWRK+1, IERR ) +* +* Perform QR iteration, accumulating Schur vectors in VR +* (CWorkspace: need 1, prefer HSWORK (see comments) ) +* (RWorkspace: none) +* + IWRK = ITAU + CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VR, LDVR, + $ WORK( IWRK ), LWORK-IWRK+1, INFO ) +* + ELSE +* +* Compute eigenvalues only +* (CWorkspace: need 1, prefer HSWORK (see comments) ) +* (RWorkspace: none) +* + IWRK = ITAU + CALL ZHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, W, VR, LDVR, + $ WORK( IWRK ), LWORK-IWRK+1, INFO ) + END IF +* +* If INFO > 0 from ZHSEQR, then quit +* + IF( INFO.GT.0 ) + $ GO TO 50 +* + IF( WANTVL .OR. WANTVR ) THEN +* +* Compute left and/or right eigenvectors +* (CWorkspace: need 2*N) +* (RWorkspace: need 2*N) +* + IRWORK = IBAL + N + CALL ZTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, + $ N, NOUT, WORK( IWRK ), RWORK( IRWORK ), IERR ) + END IF +* + IF( WANTVL ) THEN +* +* Undo balancing of left eigenvectors +* (CWorkspace: none) +* (RWorkspace: need N) +* + CALL ZGEBAK( 'B', 'L', N, ILO, IHI, RWORK( IBAL ), N, VL, LDVL, + $ IERR ) +* +* Normalize left eigenvectors and make largest component real +* + DO 20 I = 1, N + SCL = ONE / DZNRM2( N, VL( 1, I ), 1 ) + CALL ZDSCAL( N, SCL, VL( 1, I ), 1 ) + DO 10 K = 1, N + RWORK( IRWORK+K-1 ) = DBLE( VL( K, I ) )**2 + + $ DIMAG( VL( K, I ) )**2 + 10 CONTINUE + K = IDAMAX( N, RWORK( IRWORK ), 1 ) + TMP = DCONJG( VL( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) ) + CALL ZSCAL( N, TMP, VL( 1, I ), 1 ) + VL( K, I ) = DCMPLX( DBLE( VL( K, I ) ), ZERO ) + 20 CONTINUE + END IF +* + IF( WANTVR ) THEN +* +* Undo balancing of right eigenvectors +* (CWorkspace: none) +* (RWorkspace: need N) +* + CALL ZGEBAK( 'B', 'R', N, ILO, IHI, RWORK( IBAL ), N, VR, LDVR, + $ IERR ) +* +* Normalize right eigenvectors and make largest component real +* + DO 40 I = 1, N + SCL = ONE / DZNRM2( N, VR( 1, I ), 1 ) + CALL ZDSCAL( N, SCL, VR( 1, I ), 1 ) + DO 30 K = 1, N + RWORK( IRWORK+K-1 ) = DBLE( VR( K, I ) )**2 + + $ DIMAG( VR( K, I ) )**2 + 30 CONTINUE + K = IDAMAX( N, RWORK( IRWORK ), 1 ) + TMP = DCONJG( VR( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) ) + CALL ZSCAL( N, TMP, VR( 1, I ), 1 ) + VR( K, I ) = DCMPLX( DBLE( VR( K, I ) ), ZERO ) + 40 CONTINUE + END IF +* +* Undo scaling if necessary +* + 50 CONTINUE + IF( SCALEA ) THEN + CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, W( INFO+1 ), + $ MAX( N-INFO, 1 ), IERR ) + IF( INFO.GT.0 ) THEN + CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, W, N, IERR ) + END IF + END IF +* + WORK( 1 ) = MAXWRK + RETURN +* +* End of ZGEEV +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zgeev} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zgehd2 LAPACK} +%\pagehead{zgehd2}{zgehd2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zgehd2.input} +)set break resume +)sys rm -f zgehd2.output +)spool zgehd2.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zgehd2.help} +==================================================================== +zgehd2 examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) + + .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, N + .. + .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) + .. + + + Purpose: + ============= + + ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H + by a unitary similarity transformation: Q**H * A * Q = H . + + Arguments: + ========== + + [in] N + + N is INTEGER + The order of the matrix A. N >= 0. + + [in] ILO + + ILO is INTEGER + + [in] IHI + + IHI is INTEGER + + It is assumed that A is already upper triangular in rows + and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally + set by a previous call to ZGEBAL; otherwise they should be + set to 1 and N respectively. See Further Details. + 1 <= ILO <= IHI <= max(1,N). + + [in,out] A + + A is COMPLEX*16 array, dimension (LDA,N) + On entry, the n by n general matrix to be reduced. + On exit, the upper triangle and the first subdiagonal of A + are overwritten with the upper Hessenberg matrix H, and the + elements below the first subdiagonal, with the array TAU, + represent the unitary matrix Q as a product of elementary + reflectors. See Further Details. + + [in] LDA + + LDA is INTEGER + The leading dimension of the array A. LDA >= max(1,N). + + [out] TAU + + TAU is COMPLEX*16 array, dimension (N-1) + The scalar factors of the elementary reflectors (see Further + Details). + + [out] WORK + + WORK is COMPLEX*16 array, dimension (N) + + [out] INFO + + INFO is INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value. + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + + Further Details: + ===================== + + The matrix Q is represented as a product of (ihi-ilo) elementary + reflectors + + Q = H(ilo) H(ilo+1) . . . H(ihi-1). + + Each H(i) has the form + + H(i) = I - tau * v * v**H + + where tau is a complex scalar, and v is a complex vector with + v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on + exit in A(i+2:ihi,i), and tau in TAU(i). + + The contents of A are illustrated by the following example, with + n = 7, ilo = 2 and ihi = 6: + + on entry, on exit, + + ( a a a a a a a ) ( a a h h h h a ) + ( a a a a a a ) ( a h h h h a ) + ( a a a a a a ) ( h h h h h h ) + ( a a a a a a ) ( v2 h h h h h ) + ( a a a a a a ) ( v2 v3 h h h h ) + ( a a a a a a ) ( v2 v3 v4 h h h ) + ( a ) ( a ) + + where a denotes an element of the original matrix A, h denotes a + modified element of the upper Hessenberg matrix H, and vi denotes an + element of the vector defining H(i). + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I + COMPLEX*16 ALPHA +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF, ZLARFG +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, 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( 'ZGEHD2', -INFO ) + RETURN + END IF +* + DO 10 I = ILO, IHI - 1 +* +* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) +* + ALPHA = A( I+1, I ) + CALL ZLARFG( IHI-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAU( I ) ) + A( I+1, I ) = ONE +* +* Apply H(i) to A(1:ihi,i+1:ihi) from the right +* + CALL ZLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), + $ A( 1, I+1 ), LDA, WORK ) +* +* Apply H(i)**H to A(i+1:ihi,i+1:n) from the left +* + CALL ZLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, + $ DCONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK ) +* + A( I+1, I ) = ALPHA + 10 CONTINUE +* + RETURN +* +* End of ZGEHD2 +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zgehd2} \end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zgehrd LAPACK} +%\pagehead{zgehrd}{zgehrd} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zgehrd.input} +)set break resume +)sys rm -f zgehrd.output +)spool zgehrd.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zgehrd.help} +==================================================================== +zgehrd examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) + + .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, LWORK, N + .. + .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) + .. + + + Purpose: + ============= + + ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by + an unitary similarity transformation: Q**H * A * Q = H . + + Arguments: + ========== + + [in] N + + N is INTEGER + The order of the matrix A. N >= 0. + + [in] ILO + + ILO is INTEGER + + [in] IHI + + IHI is INTEGER + + It is assumed that A is already upper triangular in rows + and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally + set by a previous call to ZGEBAL; otherwise they should be + set to 1 and N respectively. See Further Details. + 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. + + [in,out] A + + A is COMPLEX*16 array, dimension (LDA,N) + On entry, the N-by-N general matrix to be reduced. + On exit, the upper triangle and the first subdiagonal of A + are overwritten with the upper Hessenberg matrix H, and the + elements below the first subdiagonal, with the array TAU, + represent the unitary matrix Q as a product of elementary + reflectors. See Further Details. + + [in] LDA + + LDA is INTEGER + The leading dimension of the array A. LDA >= max(1,N). + + [out] TAU + + TAU is COMPLEX*16 array, dimension (N-1) + The scalar factors of the elementary reflectors (see Further + Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to + zero. + + [out] WORK + + WORK is COMPLEX*16 array, dimension (LWORK) + On exit, if INFO = 0, WORK(1) returns the optimal LWORK. + + [in] LWORK + + LWORK is INTEGER + The length of the array WORK. LWORK >= max(1,N). + For optimum performance LWORK >= N*NB, where NB is the + optimal blocksize. + + If LWORK = -1, then a workspace query is assumed; the routine + only calculates the optimal size of the WORK array, returns + this value as the first entry of the WORK array, and no error + message related to LWORK is issued by XERBLA. + + [out] INFO + + INFO is INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value. + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + + Further Details: + ===================== + + The matrix Q is represented as a product of (ihi-ilo) elementary + reflectors + + Q = H(ilo) H(ilo+1) . . . H(ihi-1). + + Each H(i) has the form + + H(i) = I - tau * v * v**H + + where tau is a complex scalar, and v is a complex vector with + v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on + exit in A(i+2:ihi,i), and tau in TAU(i). + + The contents of A are illustrated by the following example, with + n = 7, ilo = 2 and ihi = 6: + + on entry, on exit, + + ( a a a a a a a ) ( a a h h h h a ) + ( a a a a a a ) ( a h h h h a ) + ( a a a a a a ) ( h h h h h h ) + ( a a a a a a ) ( v2 h h h h h ) + ( a a a a a a ) ( v2 v3 h h h h ) + ( a a a a a a ) ( v2 v3 v4 h h h ) + ( a ) ( a ) + + where a denotes an element of the original matrix A, h denotes a + modified element of the upper Hessenberg matrix H, and vi denotes an + element of the vector defining H(i). + + This file is a slight modification of LAPACK-3.0's DGEHRD + subroutine incorporating improvements proposed by Quintana-Orti and + Van de Geijn (2006). (See DLAHR2.) + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB, + $ NBMIN, NH, NX + COMPLEX*16 EI +* .. +* .. Local Arrays .. + COMPLEX*16 T( LDT, NBMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZGEHD2, ZGEMM, ZLAHR2, ZLARFB, ZTRMM, + $ 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, 'ZGEHRD', ' ', 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( 'ZGEHRD', -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, 'ZGEHRD', ' ', 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, 'ZGEHRD', ' ', 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, 'ZGEHRD', ' ', N, ILO, IHI, + $ -1 ) ) + IF( LWORK.GE.N*NBMIN ) THEN + NB = LWORK / N + ELSE + NB = 1 + END IF + END IF + END IF + END IF + LDWORK = N +* + IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN +* +* Use unblocked code below +* + I = ILO +* + ELSE +* +* Use blocked code +* + DO 40 I = ILO, IHI - 1 - NX, NB + IB = MIN( NB, IHI-I ) +* +* Reduce columns i:i+ib-1 to Hessenberg form, returning the +* matrices V and T of the block reflector H = I - V*T*V**H +* which performs the reduction, and also the matrix Y = A*V*T +* + CALL ZLAHR2( 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**H. 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 ZGEMM( 'No transpose', 'Conjugate transpose', + $ IHI, IHI-I-IB+1, + $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, + $ A( 1, I+IB ), LDA ) + A( I+IB, I+IB-1 ) = EI +* +* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the +* right +* + CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', I, IB-1, + $ ONE, A( I+1, I ), LDA, WORK, LDWORK ) + DO 30 J = 0, IB-2 + CALL ZAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1, + $ A( 1, I+J+1 ), 1 ) + 30 CONTINUE +* +* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the +* left +* + CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward', + $ 'Columnwise', + $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT, + $ A( I+1, I+IB ), LDA, WORK, LDWORK ) + 40 CONTINUE + END IF +* +* Use unblocked code to reduce the rest of the matrix +* + CALL ZGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO ) + WORK( 1 ) = IWS +* + RETURN +* +* End of ZGEHRD +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zgehrd} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zhseqr LAPACK} +%\pagehead{zhseqr}{zhseqr} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zhseqr.input} +)set break resume +)sys rm -f zhseqr.output +)spool zhseqr.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zhseqr.help} +==================================================================== +zhseqr examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, + WORK, LWORK, INFO ) + + .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N + CHARACTER COMPZ, JOB + .. + .. Array Arguments .. + COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) + .. + + + Purpose: + ============= + + ZHSEQR computes the eigenvalues of a Hessenberg matrix H + and, optionally, the matrices T and Z from the Schur decomposition + H = Z T Z**H, where T is an upper triangular matrix (the + Schur form), and Z is the unitary matrix of Schur vectors. + + Optionally Z may be postmultiplied into an input unitary + 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 unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. + + + Arguments: + ========== + + [in] JOB + + JOB is CHARACTER*1 + = 'E': compute eigenvalues only; + = 'S': compute eigenvalues and the Schur form T. + + [in] COMPZ + + COMPZ is CHARACTER*1 + = 'N': no Schur vectors are computed; + = 'I': Z is initialized to the unit matrix and the matrix Z + of Schur vectors of H is returned; + = 'V': Z must contain an unitary matrix Q on entry, and + the product Q*Z is returned. + + [in] N + + N is INTEGER + The order of the matrix H. N .GE. 0. + + [in] ILO + + ILO is INTEGER + + [in] IHI + + IHI is INTEGER + + It is assumed that H is already upper triangular in rows + and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally + set by a previous call to ZGEBAL, and then passed to ZGEHRD + when the matrix output by ZGEBAL is reduced to Hessenberg + form. Otherwise ILO and IHI should be set to 1 and N + respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. + If N = 0, then ILO = 1 and IHI = 0. + + [in,out] H + + H is COMPLEX*16 array, dimension (LDH,N) + On entry, the upper Hessenberg matrix H. + On exit, if INFO = 0 and JOB = 'S', H contains the upper + triangular matrix T from the Schur decomposition (the + Schur form). 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 ZHSEQR, 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. + + [in] LDH + + LDH is INTEGER + The leading dimension of the array H. LDH .GE. max(1,N). + + [out] W + + W is COMPLEX*16 array, dimension (N) + The computed eigenvalues. If JOB = 'S', the eigenvalues are + stored in the same order as on the diagonal of the Schur + form returned in H, with W(i) = H(i,i). + + [in,out] Z + + Z is COMPLEX*16 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 unitary 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 unitary matrix generated by ZUNGHR + after the call to ZGEHRD which formed the Hessenberg matrix + H. (The output value of Z when INFO.GT.0 is given under + the description of INFO below.) + + [in] LDZ + + LDZ is INTEGER + The leading dimension of the array Z. if COMPZ = 'I' or + COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. + + [out] WORK + + WORK is COMPLEX*16 array, dimension (LWORK) + On exit, if INFO = 0, WORK(1) returns an estimate of + the optimal value for LWORK. + + [in] LWORK + + LWORK is INTEGER + The dimension of the array WORK. LWORK .GE. max(1,N) + is sufficient and delivers very good and sometimes + optimal performance. However, LWORK as large as 11*N + may be required for optimal performance. A workspace + query is recommended to determine the optimal workspace + size. + + If LWORK = -1, then ZHSEQR does a workspace query. + In this case, ZHSEQR checks the input parameters and + estimates the optimal workspace size for the given + values of N, ILO and IHI. The estimate is returned + in WORK(1). No error message related to LWORK is + issued by XERBLA. Neither H nor Z are accessed. + + [out] INFO + + INFO is INTEGER + = 0: successful exit + .LT. 0: if INFO = -i, the i-th argument had an illegal + value + .GT. 0: if INFO = i, ZHSEQR failed to compute all of + the eigenvalues. Elements 1:ilo-1 and i+1:n of WR + and WI contain those eigenvalues which have been + successfully computed. (Failures are rare.) + + If INFO .GT. 0 and JOB = 'E', then on exit, the + remaining unconverged eigenvalues are the eigen- + values of the upper Hessenberg matrix rows and + columns ILO through INFO of the final, output + value of H. + + If INFO .GT. 0 and JOB = 'S', then on exit + + (*) (initial value of H)*U = U*(final value of H) + + where U is a unitary matrix. The final + value of H is upper Hessenberg and 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 unitary matrix in (*) (regard- + less of the value of JOB.) + + If INFO .GT. 0 and COMPZ = 'I', then on exit + (final value of Z) = U + where U is the unitary matrix in (*) (regard- + less of the value of JOB.) + + If INFO .GT. 0 and COMPZ = 'N', then Z is not + accessed. + + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + + Contributors: + ================== + + Karen Braman and Ralph Byers, Department of Mathematics, + University of Kansas, USA + + Further Details: + ===================== + + Default values supplied by + ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). + It is suggested that these defaults be adjusted in order + to attain best performance in each particular + computational environment. + + ISPEC=12: The ZLAHQR vs ZLAQR0 crossover point. + Default: 75. (Must be at least 11.) + + ISPEC=13: Recommended deflation window size. + This depends on ILO, IHI and NS. NS is the + number of simultaneous shifts returned + by ILAENV(ISPEC=15). (See ISPEC=15 below.) + The default for (IHI-ILO+1).LE.500 is NS. + The default for (IHI-ILO+1).GT.500 is 3*NS/2. + + ISPEC=14: Nibble crossover point. (See IPARMQ for + details.) Default: 14% of deflation window + size. + + ISPEC=15: Number of simultaneous shifts in a multishift + QR iteration. + + If IHI-ILO+1 is ... + + greater than ...but less ... the + or equal to ... than default is + + 1 30 NS = 2(+) + 30 60 NS = 4(+) + 60 150 NS = 10(+) + 150 590 NS = ** + 590 3000 NS = 64 + 3000 6000 NS = 128 + 6000 infinity NS = 256 + + (+) By default some or all matrices of this order + are passed to the implicit double shift routine + ZLAHQR and this parameter is ignored. See + ISPEC=12 above and comments in IPARMQ for + details. + + (**) The asterisks (**) indicate an ad-hoc + function of N increasing from 10 to 64. + + ISPEC=16: Select structured matrix multiply. + If the number of simultaneous shifts (specified + by ISPEC=15) is less than 14, then the default + for ISPEC=16 is 0. Otherwise the default for + ISPEC=16 is 2. + + References: + ================ + + K. Braman, R. Byers and R. Mathias, The Multi-Shift QR + Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 + Performance, SIAM Journal of Matrix Analysis, volume 23, pages + 929--947, 2002. + + K. Braman, R. Byers and R. Mathias, The Multi-Shift QR + Algorithm Part II: Aggressive Early Deflation, SIAM Journal + of Matrix Analysis, volume 23, pages 948--973, 2002. + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N + CHARACTER COMPZ, JOB +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. +* +* ==== Matrices of order NTINY or smaller must be processed by +* . ZLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) +* +* ==== NL allocates some local workspace to help small matrices +* . through a rare ZLAHQR failure. NL .GT. NTINY = 11 is +* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- +* . mended. (The default value of NMIN is 75.) Using NL = 49 +* . allows up to six simultaneous shifts and a 16-by-16 +* . deflation window. ==== + INTEGER NL + PARAMETER ( NL = 49 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0d0 ) +* .. +* .. Local Arrays .. + COMPLEX*16 HL( NL, NL ), WORKL( NL ) +* .. +* .. Local Scalars .. + INTEGER KBOT, NMIN + LOGICAL INITZ, LQUERY, WANTT, WANTZ +* .. +* .. External Functions .. + INTEGER ILAENV + LOGICAL LSAME + EXTERNAL ILAENV, LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZCOPY, ZLACPY, ZLAHQR, ZLAQR0, ZLASET +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, MAX, MIN +* .. +* .. Executable Statements .. +* +* ==== Decode and check the input parameters. ==== +* + WANTT = LSAME( JOB, 'S' ) + INITZ = LSAME( COMPZ, 'I' ) + WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) + WORK( 1 ) = DCMPLX( DBLE( MAX( 1, N ) ), RZERO ) + LQUERY = LWORK.EQ.-1 +* + INFO = 0 + IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -5 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.NE.0 ) THEN +* +* ==== Quick return in case of invalid argument. ==== +* + CALL XERBLA( 'ZHSEQR', -INFO ) + RETURN +* + ELSE IF( N.EQ.0 ) THEN +* +* ==== Quick return in case N = 0; nothing to do. ==== +* + RETURN +* + ELSE IF( LQUERY ) THEN +* +* ==== Quick return in case of a workspace query ==== +* + CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, Z, + $ LDZ, WORK, LWORK, INFO ) +* ==== Ensure reported workspace size is backward-compatible with +* . previous LAPACK versions. ==== + WORK( 1 ) = DCMPLX( MAX( DBLE( WORK( 1 ) ), DBLE( MAX( 1, + $ N ) ) ), RZERO ) + RETURN +* + ELSE +* +* ==== copy eigenvalues isolated by ZGEBAL ==== +* + IF( ILO.GT.1 ) + $ CALL ZCOPY( ILO-1, H, LDH+1, W, 1 ) + IF( IHI.LT.N ) + $ CALL ZCOPY( N-IHI, H( IHI+1, IHI+1 ), LDH+1, W( IHI+1 ), 1 ) +* +* ==== Initialize Z, if requested ==== +* + IF( INITZ ) + $ CALL ZLASET( 'A', N, N, ZERO, ONE, Z, LDZ ) +* +* ==== Quick return if possible ==== +* + IF( ILO.EQ.IHI ) THEN + W( ILO ) = H( ILO, ILO ) + RETURN + END IF +* +* ==== ZLAHQR/ZLAQR0 crossover point ==== +* + NMIN = ILAENV( 12, 'ZHSEQR', JOB // COMPZ, N, + $ ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) +* +* ==== ZLAQR0 for big matrices; ZLAHQR for small ones ==== +* + IF( N.GT.NMIN ) THEN + CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, + $ Z, LDZ, WORK, LWORK, INFO ) + ELSE +* +* ==== Small matrix ==== +* + CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, + $ Z, LDZ, INFO ) +* + IF( INFO.GT.0 ) THEN +* +* ==== A rare ZLAHQR failure! ZLAQR0 sometimes succeeds +* . when ZLAHQR fails. ==== +* + KBOT = INFO +* + IF( N.GE.NL ) THEN +* +* ==== Larger matrices have enough subdiagonal scratch +* . space to call ZLAQR0 directly. ==== +* + CALL ZLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, W, + $ ILO, IHI, Z, LDZ, WORK, LWORK, INFO ) +* + ELSE +* +* ==== Tiny matrices don't have enough subdiagonal +* . scratch space to benefit from ZLAQR0. Hence, +* . tiny matrices must be copied into a larger +* . array before calling ZLAQR0. ==== +* + CALL ZLACPY( 'A', N, N, H, LDH, HL, NL ) + HL( N+1, N ) = ZERO + CALL ZLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ), + $ NL ) + CALL ZLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, W, + $ ILO, IHI, Z, LDZ, WORKL, NL, INFO ) + IF( WANTT .OR. INFO.NE.0 ) + $ CALL ZLACPY( 'A', N, N, HL, NL, H, LDH ) + END IF + END IF + END IF +* +* ==== Clear out the trash, if necessary. ==== +* + IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 ) + $ CALL ZLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH ) +* +* ==== Ensure reported workspace size is backward-compatible with +* . previous LAPACK versions. ==== +* + WORK( 1 ) = DCMPLX( MAX( DBLE( MAX( 1, N ) ), + $ DBLE( WORK( 1 ) ) ), RZERO ) + END IF +* +* ==== End of ZHSEQR ==== +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zhseqr} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlacgv LAPACK} +%\pagehead{zlacgv}{zlacgv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlacgv.input} +)set break resume +)sys rm -f zlacgv.output +)spool zlacgv.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlacgv.help} +==================================================================== +zlacgv examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZLACGV( N, X, INCX ) + + .. Scalar Arguments .. + INTEGER INCX, N + .. + .. Array Arguments .. + COMPLEX*16 X( * ) + .. + + + Purpose: + ============= + + ZLACGV conjugates a complex vector of length N. + + Arguments: + ========== + + [in] N + + N is INTEGER + The length of the vector X. N >= 0. + + [in,out] X + + X is COMPLEX*16 array, dimension + (1+(N-1)*abs(INCX)) + On entry, the vector of length N to be conjugated. + On exit, X is overwritten with conjg(X). + + [in] INCX + + INCX is INTEGER + The spacing between successive elements of X. + + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZLACGV( N, X, INCX ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER INCX, N +* .. +* .. Array Arguments .. + COMPLEX*16 X( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IOFF +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. +* .. Executable Statements .. +* + IF( INCX.EQ.1 ) THEN + DO 10 I = 1, N + X( I ) = DCONJG( X( I ) ) + 10 CONTINUE + ELSE + IOFF = 1 + IF( INCX.LT.0 ) + $ IOFF = 1 - ( N-1 )*INCX + DO 20 I = 1, N + X( IOFF ) = DCONJG( X( IOFF ) ) + IOFF = IOFF + INCX + 20 CONTINUE + END IF + RETURN +* +* End of ZLACGV +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlacgv} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlacpy LAPACK} +%\pagehead{zlacpy}{zlacpy} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlacpy.input} +)set break resume +)sys rm -f zlacpy.output +)spool zlacpy.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlacpy.help} +==================================================================== +zlacpy examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) + + .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, M, N + .. + .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ) + .. + + + Purpose: + ============= + + ZLACPY copies all or part of a two-dimensional matrix A to another + matrix B. + + + Arguments: + ========== + + [in] UPLO + + UPLO is CHARACTER*1 + Specifies the part of the matrix A to be copied to B. + = 'U': Upper triangular part + = 'L': Lower triangular part + Otherwise: All of the matrix A + + [in] M + + M is INTEGER + The number of rows of the matrix A. M >= 0. + + [in] N + + N is INTEGER + The number of columns of the matrix A. N >= 0. + + [in] A + + A is COMPLEX*16 array, dimension (LDA,N) + The m by n matrix A. If UPLO = 'U', only the upper trapezium + is accessed; if UPLO = 'L', only the lower trapezium is + accessed. + + [in] LDA + + LDA is INTEGER + The leading dimension of the array A. LDA >= max(1,M). + + [out] B + + B is COMPLEX*16 array, dimension (LDB,N) + On exit, B = A in the locations specified by UPLO. + + [in] LDB + + LDB is INTEGER + The leading dimension of the array B. LDB >= max(1,M). + + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, MIN( J, M ) + B( I, J ) = A( I, J ) + 10 CONTINUE + 20 CONTINUE +* + ELSE IF( LSAME( UPLO, 'L' ) ) THEN + DO 40 J = 1, N + DO 30 I = J, M + B( I, J ) = A( I, J ) + 30 CONTINUE + 40 CONTINUE +* + ELSE + DO 60 J = 1, N + DO 50 I = 1, M + B( I, J ) = A( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF +* + RETURN +* +* End of ZLACPY +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlacpy} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zladiv LAPACK} +%\pagehead{zladiv}{zladiv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zladiv.input} +)set break resume +)sys rm -f zladiv.output +)spool zladiv.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zladiv.help} +==================================================================== +zladiv examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + COMPLEX*16 FUNCTION ZLADIV( X, Y ) + + .. Scalar Arguments .. + COMPLEX*16 X, Y + .. + + + Purpose: + ============= + + ZLADIV := X / Y, where X and Y are complex. The computation of X / Y + will not overflow on an intermediary step unless the results + overflows. + + Arguments: + ========== + + [in] X + + X is COMPLEX*16 + + [in] Y + + Y is COMPLEX*16 + The complex scalars X and Y. + + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + COMPLEX*16 FUNCTION ZLADIV( X, Y ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + COMPLEX*16 X, Y +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION ZI, ZR +* .. +* .. External Subroutines .. + EXTERNAL DLADIV +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, DIMAG +* .. +* .. Executable Statements .. +* + CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR, + $ ZI ) + ZLADIV = DCMPLX( ZR, ZI ) +* + RETURN +* +* End of ZLADIV +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zladiv} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlahqr LAPACK} +%\pagehead{zlahqr}{zlahqr} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlahqr.input} +)set break resume +)sys rm -f zlahqr.output +)spool zlahqr.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlahqr.help} +==================================================================== +zlahqr examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + IHIZ, Z, LDZ, INFO ) + + .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N + LOGICAL WANTT, WANTZ + .. + .. Array Arguments .. + COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * ) + .. + + + Purpose: + ============= + + ZLAHQR is an auxiliary routine called by CHSEQR to update the + eigenvalues and Schur decomposition already computed by CHSEQR, by + dealing with the Hessenberg submatrix in rows and columns ILO to + IHI. + + + Arguments: + ========== + + [in] WANTT + + WANTT is LOGICAL + = .TRUE. : the full Schur form T is required; + = .FALSE.: only eigenvalues are required. + + [in] WANTZ + + WANTZ is LOGICAL + = .TRUE. : the matrix of Schur vectors Z is required; + = .FALSE.: Schur vectors are not required. + + [in] N + + N is INTEGER + The order of the matrix H. N >= 0. + + [in] ILO + + ILO is INTEGER + + [in] IHI + + IHI is INTEGER + It is assumed that H is already upper triangular in rows and + columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). + ZLAHQR 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. + + [in,out] H + + H is COMPLEX*16 array, dimension (LDH,N) + On entry, the upper Hessenberg matrix H. + On exit, if INFO is zero and if WANTT is .TRUE., then H + is upper triangular in rows and columns ILO:IHI. If INFO + is zero and if WANTT is .FALSE., then the contents of H + are unspecified on exit. The output state of H in case + INF is positive is below under the description of INFO. + + [in] LDH + + LDH is INTEGER + The leading dimension of the array H. LDH >= max(1,N). + + [out] W + + W is COMPLEX*16 array, dimension (N) + The computed eigenvalues ILO to IHI are stored in the + corresponding elements of W. If WANTT is .TRUE., the + eigenvalues are stored in the same order as on the diagonal + of the Schur form returned in H, with W(i) = H(i,i). + + [in] ILOZ + + ILOZ is INTEGER + + [in] IHIZ + + IHIZ is INTEGER + Specify the rows of Z to which transformations must be + applied if WANTZ is .TRUE.. + 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. + + [in,out] Z + + Z is COMPLEX*16 array, dimension (LDZ,N) + If WANTZ is .TRUE., on entry Z must contain the current + matrix Z of transformations accumulated by CHSEQR, 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. + + [in] LDZ + + LDZ is INTEGER + The leading dimension of the array Z. LDZ >= max(1,N). + + [out] INFO + + INFO is INTEGER + = 0: successful exit + .GT. 0: if INFO = i, ZLAHQR failed to compute all the + eigenvalues ILO to IHI in a total of 30 iterations + per eigenvalue; elements i+1:ihi of W contain + those eigenvalues which have been successfully + computed. + + If INFO .GT. 0 and WANTT is .FALSE., then on exit, + the remaining unconverged eigenvalues are the + eigenvalues of the upper Hessenberg matrix + rows and columns ILO thorugh INFO of the final, + output value of H. + + If INFO .GT. 0 and WANTT is .TRUE., then on exit + (*) (initial value of H)*U = U*(final value of H) + where U is an orthognal matrix. The final + value of H is upper Hessenberg and triangular in + rows and columns INFO+1 through IHI. + + If INFO .GT. 0 and WANTZ is .TRUE., then on exit + (final value of Z) = (initial value of Z)*U + where U is the orthogonal matrix in (*) + (regardless of the value of WANTT.) + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + + Contributors: + ================== + + 02-96 Based on modifications by + David Day, Sandia National Laboratory, USA + + 12-04 Further modifications by + Ralph Byers, University of Kansas, USA + This is a modified version of ZLAHQR from LAPACK version 3.0. + It is (1) more robust against overflow and underflow and + (2) adopts the more conservative Ahues & Tisseur stopping + criterion (LAWN 122, 1997). + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, INFO ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * ) +* .. +* +* ========================================================= +* +* .. Parameters .. + INTEGER ITMAX + PARAMETER ( ITMAX = 30 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE, HALF + PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0, HALF = 0.5d0 ) + DOUBLE PRECISION DAT1 + PARAMETER ( DAT1 = 3.0d0 / 4.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U, + $ V2, X, Y + DOUBLE PRECISION AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX, + $ SAFMIN, SMLNUM, SX, T2, TST, ULP + INTEGER I, I1, I2, ITS, J, JHI, JLO, K, L, M, NH, NZ +* .. +* .. Local Arrays .. + COMPLEX*16 V( 2 ) +* .. +* .. External Functions .. + COMPLEX*16 ZLADIV + DOUBLE PRECISION DLAMCH + EXTERNAL ZLADIV, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, ZCOPY, ZLARFG, ZSCAL +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* + INFO = 0 +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN + IF( ILO.EQ.IHI ) THEN + W( ILO ) = H( ILO, ILO ) + RETURN + END IF +* +* ==== clear out the trash ==== + DO 10 J = ILO, IHI - 3 + H( J+2, J ) = ZERO + H( J+3, J ) = ZERO + 10 CONTINUE + IF( ILO.LE.IHI-2 ) + $ H( IHI, IHI-2 ) = ZERO +* ==== ensure that subdiagonal entries are real ==== + IF( WANTT ) THEN + JLO = 1 + JHI = N + ELSE + JLO = ILO + JHI = IHI + END IF + DO 20 I = ILO + 1, IHI + IF( DIMAG( H( I, I-1 ) ).NE.RZERO ) THEN +* ==== The following redundant normalization +* . avoids problems with both gradual and +* . sudden underflow in ABS(H(I,I-1)) ==== + SC = H( I, I-1 ) / CABS1( H( I, I-1 ) ) + SC = DCONJG( SC ) / ABS( SC ) + H( I, I-1 ) = ABS( H( I, I-1 ) ) + CALL ZSCAL( JHI-I+1, SC, H( I, I ), LDH ) + CALL ZSCAL( MIN( JHI, I+1 )-JLO+1, DCONJG( SC ), + $ H( JLO, I ), 1 ) + IF( WANTZ ) + $ CALL ZSCAL( IHIZ-ILOZ+1, DCONJG( SC ), Z( ILOZ, I ), 1 ) + END IF + 20 CONTINUE +* + NH = IHI - ILO + 1 + NZ = IHIZ - ILOZ + 1 +* +* Set machine-dependent constants for the stopping criterion. +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( NH ) / ULP ) +* +* I1 and I2 are the indices of the first row and last column of H +* to which transformations must be applied. If eigenvalues only are +* being computed, I1 and I2 are set inside the main loop. +* + IF( WANTT ) THEN + I1 = 1 + I2 = N + END IF +* +* The main loop begins here. I is the loop index and decreases from +* IHI to ILO in steps of 1. 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 + 30 CONTINUE + IF( I.LT.ILO ) + $ GO TO 150 +* +* Perform QR iterations on rows and columns ILO to I until a +* submatrix of order 1 splits off at the bottom because a +* subdiagonal element has become negligible. +* + L = ILO + DO 130 ITS = 0, ITMAX +* +* Look for a single small subdiagonal element. +* + DO 40 K = I, L + 1, -1 + IF( CABS1( H( K, K-1 ) ).LE.SMLNUM ) + $ GO TO 50 + TST = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) ) + IF( TST.EQ.ZERO ) THEN + IF( K-2.GE.ILO ) + $ TST = TST + ABS( DBLE( H( K-1, K-2 ) ) ) + IF( K+1.LE.IHI ) + $ TST = TST + ABS( DBLE( H( K+1, K ) ) ) + END IF +* ==== The following is a conservative small subdiagonal +* . deflation criterion due to Ahues & Tisseur (LAWN 122, +* . 1997). It has better mathematical foundation and +* . improves accuracy in some examples. ==== + IF( ABS( DBLE( H( K, K-1 ) ) ).LE.ULP*TST ) THEN + AB = MAX( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) + BA = MIN( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) + AA = MAX( CABS1( H( K, K ) ), + $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) + BB = MIN( CABS1( H( K, K ) ), + $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) + S = AA + AB + IF( BA*( AB / S ).LE.MAX( SMLNUM, + $ ULP*( BB*( AA / S ) ) ) )GO TO 50 + END IF + 40 CONTINUE + 50 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 has split off. +* + IF( L.GE.I ) + $ 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 ) THEN +* +* Exceptional shift. +* + S = DAT1*ABS( DBLE( H( L+1, L ) ) ) + T = S + H( L, L ) + ELSE IF( ITS.EQ.20 ) THEN +* +* Exceptional shift. +* + S = DAT1*ABS( DBLE( H( I, I-1 ) ) ) + T = S + H( I, I ) + ELSE +* +* Wilkinson's shift. +* + T = H( I, I ) + U = SQRT( H( I-1, I ) )*SQRT( H( I, I-1 ) ) + S = CABS1( U ) + IF( S.NE.RZERO ) THEN + X = HALF*( H( I-1, I-1 )-T ) + SX = CABS1( X ) + S = MAX( S, CABS1( X ) ) + Y = S*SQRT( ( X / S )**2+( U / S )**2 ) + IF( SX.GT.RZERO ) THEN + IF( DBLE( X / SX )*DBLE( Y )+DIMAG( X / SX )* + $ DIMAG( Y ).LT.RZERO )Y = -Y + END IF + T = T - U*ZLADIV( U, ( X+Y ) ) + END IF + END IF +* +* Look for two consecutive small subdiagonal elements. +* + DO 60 M = I - 1, L + 1, -1 +* +* Determine the effect of starting the single-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 ) + H11S = H11 - T + H21 = DBLE( H( M+1, M ) ) + S = CABS1( H11S ) + ABS( H21 ) + H11S = H11S / S + H21 = H21 / S + V( 1 ) = H11S + V( 2 ) = H21 + H10 = DBLE( H( M, M-1 ) ) + IF( ABS( H10 )*ABS( H21 ).LE.ULP* + $ ( CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ) ) + $ GO TO 70 + 60 CONTINUE + H11 = H( L, L ) + H22 = H( L+1, L+1 ) + H11S = H11 - T + H21 = DBLE( H( L+1, L ) ) + S = CABS1( H11S ) + ABS( H21 ) + H11S = H11S / S + H21 = H21 / S + V( 1 ) = H11S + V( 2 ) = H21 + 70 CONTINUE +* +* Single-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. +* +* V(2) is always real before the call to ZLARFG, and hence +* after the call T2 ( = T1*V(2) ) is also real. +* + IF( K.GT.M ) + $ CALL ZCOPY( 2, H( K, K-1 ), 1, V, 1 ) + CALL ZLARFG( 2, V( 1 ), V( 2 ), 1, T1 ) + IF( K.GT.M ) THEN + H( K, K-1 ) = V( 1 ) + H( K+1, K-1 ) = ZERO + END IF + V2 = V( 2 ) + T2 = DBLE( T1*V2 ) +* +* Apply G from the left to transform the rows of the matrix +* in columns K to I2. +* + DO 80 J = K, I2 + SUM = DCONJG( T1 )*H( K, J ) + T2*H( K+1, J ) + H( K, J ) = H( K, J ) - SUM + H( K+1, J ) = H( K+1, J ) - SUM*V2 + 80 CONTINUE +* +* Apply G from the right to transform the columns of the +* matrix in rows I1 to min(K+2,I). +* + DO 90 J = I1, MIN( K+2, I ) + SUM = T1*H( J, K ) + T2*H( J, K+1 ) + H( J, K ) = H( J, K ) - SUM + H( J, K+1 ) = H( J, K+1 ) - SUM*DCONJG( V2 ) + 90 CONTINUE +* + IF( WANTZ ) THEN +* +* Accumulate transformations in the matrix Z +* + DO 100 J = ILOZ, IHIZ + SUM = T1*Z( J, K ) + T2*Z( J, K+1 ) + Z( J, K ) = Z( J, K ) - SUM + Z( J, K+1 ) = Z( J, K+1 ) - SUM*DCONJG( V2 ) + 100 CONTINUE + END IF +* + IF( K.EQ.M .AND. M.GT.L ) THEN +* +* If the QR step was started at row M > L because two +* consecutive small subdiagonals were found, then extra +* scaling must be performed to ensure that H(M,M-1) remains +* real. +* + TEMP = ONE - T1 + TEMP = TEMP / ABS( TEMP ) + H( M+1, M ) = H( M+1, M )*DCONJG( TEMP ) + IF( M+2.LE.I ) + $ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP + DO 110 J = M, I + IF( J.NE.M+1 ) THEN + IF( I2.GT.J ) + $ CALL ZSCAL( I2-J, TEMP, H( J, J+1 ), LDH ) + CALL ZSCAL( J-I1, DCONJG( TEMP ), H( I1, J ), 1 ) + IF( WANTZ ) THEN + CALL ZSCAL( NZ, DCONJG( TEMP ), Z( ILOZ, J ), + $ 1 ) + END IF + END IF + 110 CONTINUE + END IF + 120 CONTINUE +* +* Ensure that H(I,I-1) is real. +* + TEMP = H( I, I-1 ) + IF( DIMAG( TEMP ).NE.RZERO ) THEN + RTEMP = ABS( TEMP ) + H( I, I-1 ) = RTEMP + TEMP = TEMP / RTEMP + IF( I2.GT.I ) + $ CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH ) + CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 ) + IF( WANTZ ) THEN + CALL ZSCAL( NZ, TEMP, Z( ILOZ, I ), 1 ) + END IF + END IF +* + 130 CONTINUE +* +* Failure to converge in remaining number of iterations +* + INFO = I + RETURN +* + 140 CONTINUE +* +* H(I,I-1) is negligible: one eigenvalue has converged. +* + W( I ) = H( I, I ) +* +* return to start of the main loop with new value of I. +* + I = L - 1 + GO TO 30 +* + 150 CONTINUE + RETURN +* +* End of ZLAHQR +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlahqr} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlahr2 LAPACK} +%\pagehead{zlahr2}{zlahr2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlahr2.input} +)set break resume +)sys rm -f zlahr2.output +)spool zlahr2.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlahr2.help} +==================================================================== +zlahr2 examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) + + .. Scalar Arguments .. + INTEGER K, LDA, LDT, LDY, N, NB + .. + .. Array Arguments .. + COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ), + $ Y( LDY, NB ) + .. + + + Purpose: + ============= + + ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1) + matrix A so that elements below the k-th subdiagonal are zero. The + reduction is performed by an unitary similarity transformation + Q**H * A * Q. The routine returns the matrices V and T which determine + Q as a block reflector I - V*T*V**H, and also the matrix Y = A * V * T. + + This is an auxiliary routine called by ZGEHRD. + + Arguments: + ========== + + [in] N + + N is INTEGER + The order of the matrix A. + + [in] K + + K is INTEGER + The offset for the reduction. Elements below the k-th + subdiagonal in the first NB columns are reduced to zero. + K < N. + + [in] NB + + NB is INTEGER + The number of columns to be reduced. + + [in,out] A + + A is COMPLEX*16 array, dimension (LDA,N-K+1) + On entry, the n-by-(n-k+1) general matrix A. + On exit, the elements on and above the k-th subdiagonal in + the first NB columns are overwritten with the corresponding + elements of the reduced matrix; the elements below the k-th + subdiagonal, with the array TAU, represent the matrix Q as a + product of elementary reflectors. The other columns of A are + unchanged. See Further Details. + + [in] LDA + + LDA is INTEGER + The leading dimension of the array A. LDA >= max(1,N). + + [out] TAU + + TAU is COMPLEX*16 array, dimension (NB) + The scalar factors of the elementary reflectors. See Further + Details. + + [out] T + + T is COMPLEX*16 array, dimension (LDT,NB) + The upper triangular matrix T. + + [in] LDT + + LDT is INTEGER + The leading dimension of the array T. LDT >= NB. + + [out] Y + + Y is COMPLEX*16 array, dimension (LDY,NB) + The n-by-nb matrix Y. + + [in] LDY + + LDY is INTEGER + The leading dimension of the array Y. LDY >= N. + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + + Further Details: + ===================== + + The matrix Q is represented as a product of nb elementary reflectors + + Q = H(1) H(2) . . . H(nb). + + Each H(i) has the form + + H(i) = I - tau * v * v**H + + where tau is a complex scalar, and v is a complex vector with + v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in + A(i+k+1:n,i), and tau in TAU(i). + + The elements of the vectors v together form the (n-k+1)-by-nb matrix + V which is needed, with T and Y, to apply the transformation to the + unreduced part of the matrix, using an update of the form: + A := (I - V*T*V**H) * (A - Y*V**H). + + The contents of A on exit are illustrated by the following example + with n = 7, k = 3 and nb = 2: + + ( a a a a a ) + ( a a a a a ) + ( a a a a a ) + ( h h a a a ) + ( v1 h a a a ) + ( v1 v2 a a a ) + ( v1 v2 a a a ) + + where a denotes an element of the original matrix A, h denotes a + modified element of the upper Hessenberg matrix H, and vi denotes an + element of the vector defining H(i). + + This subroutine is a slight modification of LAPACK-3.0's DLAHRD + incorporating improvements proposed by Quintana-Orti and Van de + Gejin. Note that the entries of A(1:K,2:NB) differ from those + returned by the original LAPACK-3.0's DLAHRD routine. (This + subroutine is not backward compatible with LAPACK-3.0's DLAHRD.) + + References: + ================ + + Gregorio Quintana-Orti and Robert van de Geijn, "Improving the + performance of reduction to Hessenberg form," ACM Transactions on + Mathematical Software, 32(2):180-194, June 2006. + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER K, LDA, LDT, LDY, N, NB +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ), + $ Y( LDY, NB ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I + COMPLEX*16 EI +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZCOPY, ZGEMM, ZGEMV, ZLACPY, + $ ZLARFG, ZSCAL, ZTRMM, ZTRMV, ZLACGV +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* + DO 10 I = 1, NB + IF( I.GT.1 ) THEN +* +* Update A(K+1:N,I) +* +* Update I-th column of A - Y * V**H +* + CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) + CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY, + $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 ) + CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) +* +* Apply I - V * T**H * V**H 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**H * b1 +* + CALL ZCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) + CALL ZTRMV( 'Lower', 'Conjugate transpose', 'UNIT', + $ I-1, A( K+1, 1 ), + $ LDA, T( 1, NB ), 1 ) +* +* w := w + V2**H * b2 +* + CALL ZGEMV( 'Conjugate 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**H * w +* + CALL ZTRMV( 'Upper', 'Conjugate transpose', 'NON-UNIT', + $ I-1, T, LDT, + $ T( 1, NB ), 1 ) +* +* b2 := b2 - V2*w +* + CALL ZGEMV( '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 ZTRMV( 'Lower', 'NO TRANSPOSE', + $ 'UNIT', I-1, + $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) + CALL ZAXPY( 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 ZLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, + $ TAU( I ) ) + EI = A( K+I, I ) + A( K+I, I ) = ONE +* +* Compute Y(K+1:N,I) +* + CALL ZGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, + $ ONE, A( K+1, I+1 ), + $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 ) + CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, + $ ONE, A( K+I, 1 ), LDA, + $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) + CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, + $ Y( K+1, 1 ), LDY, + $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 ) + CALL ZSCAL( N-K, TAU( I ), Y( K+1, I ), 1 ) +* +* Compute T(1:I,I) +* + CALL ZSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) + CALL ZTRMV( 'Upper', 'No Transpose', 'NON-UNIT', + $ I-1, T, LDT, + $ T( 1, I ), 1 ) + T( I, I ) = TAU( I ) +* + 10 CONTINUE + A( K+NB, NB ) = EI +* +* Compute Y(1:K,1:NB) +* + CALL ZLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) + CALL ZTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', + $ 'UNIT', K, NB, + $ ONE, A( K+1, 1 ), LDA, Y, LDY ) + IF( N.GT.K+NB ) + $ CALL ZGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, + $ NB, N-K-NB, ONE, + $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y, + $ LDY ) + CALL ZTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', + $ 'NON-UNIT', K, NB, + $ ONE, T, LDT, Y, LDY ) +* + RETURN +* +* End of ZLAHR2 +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlahr2} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlange LAPACK} +%\pagehead{zlange}{zlange} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlange.input} +)set break resume +)sys rm -f zlange.output +)spool zlange.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlange.help} +==================================================================== +zlange examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) + + .. Scalar Arguments .. + CHARACTER NORM + INTEGER LDA, M, N + .. + .. Array Arguments .. + DOUBLE PRECISION WORK( * ) + COMPLEX*16 A( LDA, * ) + .. + + + Purpose: + ============= + + ZLANGE returns the value of the one norm, or the Frobenius norm, or + the infinity norm, or the element of largest absolute value of a + complex matrix A. + + + ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' + ( + ( norm1(A), NORM = '1', 'O' or 'o' + ( + ( normI(A), NORM = 'I' or 'i' + ( + ( normF(A), NORM = 'F', 'f', 'E' or 'e' + + where norm1 denotes the one norm of a matrix (maximum column sum), + normI denotes the infinity norm of a matrix (maximum row sum) and + normF denotes the Frobenius norm of a matrix (square root of sum of + squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. + + Arguments: + ========== + + [in] NORM + + NORM is CHARACTER*1 + Specifies the value to be returned in ZLANGE as described + above. + + [in] M + + M is INTEGER + The number of rows of the matrix A. M >= 0. When M = 0, + ZLANGE is set to zero. + + [in] N + + N is INTEGER + The number of columns of the matrix A. N >= 0. When N = 0, + ZLANGE is set to zero. + + [in] A + + A is COMPLEX*16 array, dimension (LDA,N) + The m by n matrix A. + + [in] LDA + + LDA is INTEGER + The leading dimension of the array A. LDA >= max(M,1). + + [out] WORK + + WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), + where LWORK >= M when NORM = 'I'; otherwise, WORK is not + referenced. + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION WORK( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION SCALE, SUM, VALUE +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLASSQ +* .. +* .. 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 ZLASSQ( M, A( 1, J ), 1, SCALE, SUM ) + 90 CONTINUE + VALUE = SCALE*SQRT( SUM ) + END IF +* + ZLANGE = VALUE + RETURN +* +* End of ZLANGE +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlange} +(let* ((one 1.0) (zero 0.0)) + (declare (type (double-float 1.0 1.0) one) + (type (double-float 0.0 0.0) zero)) + (defun zlange (norm m n a lda work) + (declare (type (simple-array double-float (*)) work) + (type (simple-array (complex double-float) (*)) a) + (type fixnum lda n m) + (type character norm)) + (f2cl-lib:with-multi-array-data + ((norm character norm-%data% norm-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((scale 0.0) (sum 0.0) (value 0.0) (i 0) (j 0) (zlange 0.0)) + (declare (type fixnum i j) + (type (double-float) scale sum value zlange)) + (cond + ((= (min (the fixnum m) (the fixnum n)) 0) + (setf value zero)) + ((char-equal norm #\M) + (setf value zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf value + (max value + (abs + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%))))))))) + ((or (char-equal norm #\O) (f2cl-lib:fstring-= norm "1")) + (setf value zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf sum zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf sum + (+ sum + (abs + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf value (max value sum))))) + ((char-equal norm #\I) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) + zero))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) + (+ + (f2cl-lib:fref work-%data% + (i) + ((1 *)) + work-%offset%) + (abs + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))))) + (setf value zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf value + (max value + (f2cl-lib:fref work-%data% + (i) + ((1 *)) + work-%offset%)))))) + ((or (char-equal norm #\F) (char-equal norm #\E)) + (setf scale zero) + (setf sum one) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (zlassq m + (f2cl-lib:array-slice a + (complex double-float) + (1 j) + ((1 lda) (1 *))) + 1 scale sum) + (declare (ignore var-0 var-1 var-2)) + (setf scale var-3) + (setf sum var-4)))) + (setf value (* scale (f2cl-lib:fsqrt sum))))) + (setf zlange value) + (return (values zlange nil nil nil nil nil nil)))))) + +\end{chunk} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlaqr0 LAPACK} +%\pagehead{zlaqr0}{zlaqr0} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlaqr0.input} +)set break resume +)sys rm -f zlaqr0.output +)spool zlaqr0.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlaqr0.help} +==================================================================== +zlaqr0 examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + IHIZ, Z, LDZ, WORK, LWORK, INFO ) + + .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ + .. + .. Array Arguments .. + COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) + .. + + + Purpose: + ============= + + ZLAQR0 computes the eigenvalues of a Hessenberg matrix H + and, optionally, the matrices T and Z from the Schur decomposition + H = Z T Z**H, where T is an upper triangular matrix (the + Schur form), and Z is the unitary matrix of Schur vectors. + + Optionally Z may be postmultiplied into an input unitary + 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 unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. + + Arguments: + ========== + + [in] WANTT + + WANTT is LOGICAL + = .TRUE. : the full Schur form T is required; + = .FALSE.: only eigenvalues are required. + + [in] WANTZ + + WANTZ is LOGICAL + = .TRUE. : the matrix of Schur vectors Z is required; + = .FALSE.: Schur vectors are not required. + + [in] N + + N is INTEGER + The order of the matrix H. N .GE. 0. + + [in] ILO + + ILO is INTEGER + + [in] IHI + + IHI is INTEGER + + It is assumed that H is already upper triangular in rows + and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, + H(ILO,ILO-1) is zero. ILO and IHI are normally set by a + previous call to ZGEBAL, and then passed to ZGEHRD when the + matrix output by ZGEBAL is reduced to Hessenberg form. + Otherwise, ILO and IHI should be set to 1 and N, + respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. + If N = 0, then ILO = 1 and IHI = 0. + + [in,out] H + + H is COMPLEX*16 array, dimension (LDH,N) + On entry, the upper Hessenberg matrix H. + On exit, if INFO = 0 and WANTT is .TRUE., then H + contains the upper triangular matrix T from the Schur + decomposition (the Schur form). If INFO = 0 and WANT is + .FALSE., then the contents of H are unspecified on exit. + (The output value of H when INFO.GT.0 is given under the + description of INFO below.) + + This subroutine may explicitly set H(i,j) = 0 for i.GT.j and + j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. + + [in] LDH + + LDH is INTEGER + The leading dimension of the array H. LDH .GE. max(1,N). + + [out] W + + W is COMPLEX*16 array, dimension (N) + The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored + in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are + stored in the same order as on the diagonal of the Schur + form returned in H, with W(i) = H(i,i). + + [in] ILOZ + + ILOZ is INTEGER + + [in] IHIZ + + IHIZ is INTEGER + Specify the rows of Z to which transformations must be + applied if WANTZ is .TRUE.. + 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. + + [in,out] Z + + Z is COMPLEX*16 array, dimension (LDZ,IHI) + If WANTZ is .FALSE., then Z is not referenced. + If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is + replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the + orthogonal Schur factor of H(ILO:IHI,ILO:IHI). + (The output value of Z when INFO.GT.0 is given under + the description of INFO below.) + + [in] LDZ + + LDZ is INTEGER + The leading dimension of the array Z. if WANTZ is .TRUE. + then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. + + [out] WORK + + WORK is COMPLEX*16 array, dimension LWORK + On exit, if LWORK = -1, WORK(1) returns an estimate of + the optimal value for LWORK. + + [in] LWORK + + LWORK is INTEGER + The dimension of the array WORK. LWORK .GE. max(1,N) + is sufficient, but LWORK typically as large as 6*N may + be required for optimal performance. A workspace query + to determine the optimal workspace size is recommended. + + If LWORK = -1, then ZLAQR0 does a workspace query. + In this case, ZLAQR0 checks the input parameters and + estimates the optimal workspace size for the given + values of N, ILO and IHI. The estimate is returned + in WORK(1). No error message related to LWORK is + issued by XERBLA. Neither H nor Z are accessed. + + [out] INFO + + INFO is INTEGER + = 0: successful exit + .GT. 0: if INFO = i, ZLAQR0 failed to compute all of + the eigenvalues. Elements 1:ilo-1 and i+1:n of WR + and WI contain those eigenvalues which have been + successfully computed. (Failures are rare.) + + If INFO .GT. 0 and WANT is .FALSE., then on exit, + the remaining unconverged eigenvalues are the eigen- + values of the upper Hessenberg matrix rows and + columns ILO through INFO of the final, output + value of H. + + If INFO .GT. 0 and WANTT is .TRUE., then on exit + + (*) (initial value of H)*U = U*(final value of H) + + where U is a unitary matrix. The final + value of H is upper Hessenberg and triangular in + rows and columns INFO+1 through IHI. + + If INFO .GT. 0 and WANTZ is .TRUE., then on exit + + (final value of Z(ILO:IHI,ILOZ:IHIZ) + = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U + + where U is the unitary matrix in (*) (regard- + less of the value of WANTT.) + + If INFO .GT. 0 and WANTZ is .FALSE., then Z is not + accessed. + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + + Contributors: + ================== + + Karen Braman and Ralph Byers, Department of Mathematics, + University of Kansas, USA + + References: + ================ + + K. Braman, R. Byers and R. Mathias, The Multi-Shift QR + Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 + Performance, SIAM Journal of Matrix Analysis, volume 23, pages + 929--947, 2002. + + K. Braman, R. Byers and R. Mathias, The Multi-Shift QR + Algorithm Part II: Aggressive Early Deflation, SIAM Journal + of Matrix Analysis, volume 23, pages 948--973, 2002. + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ================================================================ +* +* .. Parameters .. +* +* ==== Matrices of order NTINY or smaller must be processed by +* . ZLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) +* +* ==== Exceptional deflation windows: try to cure rare +* . slow convergence by varying the size of the +* . deflation window after KEXNW iterations. ==== + INTEGER KEXNW + PARAMETER ( KEXNW = 5 ) +* +* ==== Exceptional shifts: try to cure rare slow convergence +* . with ad-hoc exceptional shifts every KEXSH iterations. +* . ==== + INTEGER KEXSH + PARAMETER ( KEXSH = 6 ) +* +* ==== The constant WILK1 is used to form the exceptional +* . shifts. ==== + DOUBLE PRECISION WILK1 + PARAMETER ( WILK1 = 0.75d0 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 + DOUBLE PRECISION S + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, + $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, + $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD + LOGICAL SORTED + CHARACTER JBCMPZ*2 +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Local Arrays .. + COMPLEX*16 ZDUM( 1, 1 ) +* .. +* .. External Subroutines .. + EXTERNAL ZLACPY, ZLAHQR, ZLAQR3, ZLAQR4, ZLAQR5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, + $ SQRT +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. + INFO = 0 +* +* ==== Quick return for N = 0: nothing to do. ==== +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = ONE + RETURN + END IF +* + IF( N.LE.NTINY ) THEN +* +* ==== Tiny matrices must use ZLAHQR. ==== +* + LWKOPT = 1 + IF( LWORK.NE.-1 ) + $ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, INFO ) + ELSE +* +* ==== Use small bulge multi-shift QR with aggressive early +* . deflation on larger-than-tiny matrices. ==== +* +* ==== Hope for the best. ==== +* + INFO = 0 +* +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* +* ==== NWR = recommended deflation window size. At this +* . point, N .GT. NTINY = 11, so there is enough +* . subdiagonal workspace for NWR.GE.2 as required. +* . (In fact, there is enough subdiagonal space for +* . NWR.GE.3.) ==== +* + NWR = ILAENV( 13, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NWR = MAX( 2, NWR ) + NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) +* +* ==== NSR = recommended number of simultaneous shifts. +* . At this point N .GT. NTINY = 11, so there is at +* . enough subdiagonal workspace for NSR to be even +* . and greater than or equal to two as required. ==== +* + NSR = ILAENV( 15, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) + NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) +* +* ==== Estimate optimal workspace ==== +* +* ==== Workspace query call to ZLAQR3 ==== +* + CALL ZLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, + $ LDH, WORK, -1 ) +* +* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR3) ==== +* + LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF +* +* ==== ZLAHQR/ZLAQR0 crossover point ==== +* + NMIN = ILAENV( 12, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) +* +* ==== Nibble crossover point ==== +* + NIBBLE = ILAENV( 14, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + NIBBLE = MAX( 0, NIBBLE ) +* +* ==== Accumulate reflections during ttswp? Use block +* . 2-by-2 structure during matrix-matrix multiply? ==== +* + KACC22 = ILAENV( 16, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) + KACC22 = MAX( 0, KACC22 ) + KACC22 = MIN( 2, KACC22 ) +* +* ==== NWMAX = the largest possible deflation window for +* . which there is sufficient workspace. ==== +* + NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) + NW = NWMAX +* +* ==== NSMAX = the Largest number of simultaneous shifts +* . for which there is sufficient workspace. ==== +* + NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) + NSMAX = NSMAX - MOD( NSMAX, 2 ) +* +* ==== NDFL: an iteration count restarted at deflation. ==== +* + NDFL = 1 +* +* ==== ITMAX = iteration limit ==== +* + ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) +* +* ==== Last row and column in the active block ==== +* + KBOT = IHI +* +* ==== Main Loop ==== +* + DO 70 IT = 1, ITMAX +* +* ==== Done when KBOT falls below ILO ==== +* + IF( KBOT.LT.ILO ) + $ GO TO 80 +* +* ==== Locate active block ==== +* + DO 10 K = KBOT, ILO + 1, -1 + IF( H( K, K-1 ).EQ.ZERO ) + $ GO TO 20 + 10 CONTINUE + K = ILO + 20 CONTINUE + KTOP = K +* +* ==== Select deflation window size: +* . Typical Case: +* . If possible and advisable, nibble the entire +* . active block. If not, use size MIN(NWR,NWMAX) +* . or MIN(NWR+1,NWMAX) depending upon which has +* . the smaller corresponding subdiagonal entry +* . (a heuristic). +* . +* . Exceptional Case: +* . If there have been no deflations in KEXNW or +* . more iterations, then vary the deflation window +* . size. At first, because, larger windows are, +* . in general, more powerful than smaller ones, +* . rapidly increase the window to the maximum possible. +* . Then, gradually reduce the window size. ==== +* + NH = KBOT - KTOP + 1 + NWUPBD = MIN( NH, NWMAX ) + IF( NDFL.LT.KEXNW ) THEN + NW = MIN( NWUPBD, NWR ) + ELSE + NW = MIN( NWUPBD, 2*NW ) + END IF + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH + ELSE + KWTOP = KBOT - NW + 1 + IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. + $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 + END IF + END IF + IF( NDFL.LT.KEXNW ) THEN + NDEC = -1 + ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN + NDEC = NDEC + 1 + IF( NW-NDEC.LT.2 ) + $ NDEC = 0 + NW = NW - NDEC + END IF +* +* ==== Aggressive early deflation: +* . split workspace under the subdiagonal into +* . - an nw-by-nw work array V in the lower +* . left-hand-corner, +* . - an NW-by-at-least-NW-but-more-is-better +* . (NW-by-NHO) horizontal work array along +* . the bottom edge, +* . - an at-least-NW-but-more-is-better (NHV-by-NW) +* . vertical work array along the left-hand-edge. +* . ==== +* + KV = N - NW + 1 + KT = NW + 1 + NHO = ( N-NW-1 ) - KT + 1 + KWV = NW + 2 + NVE = ( N-NW ) - KWV + 1 +* +* ==== Aggressive early deflation ==== +* + CALL ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, + $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, + $ LWORK ) +* +* ==== Adjust KBOT accounting for new deflations. ==== +* + KBOT = KBOT - LD +* +* ==== KS points to the shifts. ==== +* + KS = KBOT - LS + 1 +* +* ==== Skip an expensive QR sweep if there is a (partly +* . heuristic) reason to expect that many eigenvalues +* . will deflate without it. Here, the QR sweep is +* . skipped if many eigenvalues have just been deflated +* . or if the remaining active block is small. +* + IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- + $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN +* +* ==== NS = nominal number of simultaneous shifts. +* . This may be lowered (slightly) if ZLAQR3 +* . did not provide that many shifts. ==== +* + NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) + NS = NS - MOD( NS, 2 ) +* +* ==== If there have been no deflations +* . in a multiple of KEXSH iterations, +* . then try exceptional shifts. +* . Otherwise use shifts provided by +* . ZLAQR3 above or from the eigenvalues +* . of a trailing principal submatrix. ==== +* + IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN + KS = KBOT - NS + 1 + DO 30 I = KBOT, KS + 1, -2 + W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) + W( I-1 ) = W( I ) + 30 CONTINUE + ELSE +* +* ==== Got NS/2 or fewer shifts? Use ZLAQR4 or +* . ZLAHQR on a trailing principal submatrix to +* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, +* . there is enough space below the subdiagonal +* . to fit an NS-by-NS scratch array.) ==== +* + IF( KBOT-KS+1.LE.NS / 2 ) THEN + KS = KBOT - NS + 1 + KT = N - NS + 1 + CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH, + $ H( KT, 1 ), LDH ) + IF( NS.GT.NMIN ) THEN + CALL ZLAQR4( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, W( KS ), 1, 1, + $ ZDUM, 1, WORK, LWORK, INF ) + ELSE + CALL ZLAHQR( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, W( KS ), 1, 1, + $ ZDUM, 1, INF ) + END IF + KS = KS + INF +* +* ==== In case of a rare QR failure use +* . eigenvalues of the trailing 2-by-2 +* . principal submatrix. Scale to avoid +* . overflows, underflows and subnormals. +* . (The scale factor S can not be zero, +* . because H(KBOT,KBOT-1) is nonzero.) ==== +* + IF( KS.GE.KBOT ) THEN + S = CABS1( H( KBOT-1, KBOT-1 ) ) + + $ CABS1( H( KBOT, KBOT-1 ) ) + + $ CABS1( H( KBOT-1, KBOT ) ) + + $ CABS1( H( KBOT, KBOT ) ) + AA = H( KBOT-1, KBOT-1 ) / S + CC = H( KBOT, KBOT-1 ) / S + BB = H( KBOT-1, KBOT ) / S + DD = H( KBOT, KBOT ) / S + TR2 = ( AA+DD ) / TWO + DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC + RTDISC = SQRT( -DET ) + W( KBOT-1 ) = ( TR2+RTDISC )*S + W( KBOT ) = ( TR2-RTDISC )*S +* + KS = KBOT - 1 + END IF + END IF +* + IF( KBOT-KS+1.GT.NS ) THEN +* +* ==== Sort the shifts (Helps a little) ==== +* + SORTED = .false. + DO 50 K = KBOT, KS + 1, -1 + IF( SORTED ) + $ GO TO 60 + SORTED = .true. + DO 40 I = KS, K - 1 + IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) + $ THEN + SORTED = .false. + SWAP = W( I ) + W( I ) = W( I+1 ) + W( I+1 ) = SWAP + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF + END IF +* +* ==== If there are only two shifts, then use +* . only one. ==== +* + IF( KBOT-KS+1.EQ.2 ) THEN + IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. + $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN + W( KBOT-1 ) = W( KBOT ) + ELSE + W( KBOT ) = W( KBOT-1 ) + END IF + END IF +* +* ==== Use up to NS of the the smallest magnatiude +* . shifts. If there aren't NS shifts available, +* . then use them all, possibly dropping one to +* . make the number of shifts even. ==== +* + NS = MIN( NS, KBOT-KS+1 ) + NS = NS - MOD( NS, 2 ) + KS = KBOT - NS + 1 +* +* ==== Small-bulge multi-shift QR sweep: +* . split workspace under the subdiagonal into +* . - a KDU-by-KDU work array U in the lower +* . left-hand-corner, +* . - a KDU-by-at-least-KDU-but-more-is-better +* . (KDU-by-NHo) horizontal work array WH along +* . the bottom edge, +* . - and an at-least-KDU-but-more-is-better-by-KDU +* . (NVE-by-KDU) vertical work WV arrow along +* . the left-hand-edge. ==== +* + KDU = 3*NS - 3 + KU = N - KDU + 1 + KWH = KDU + 1 + NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 + KWV = KDU + 4 + NVE = N - KDU - KWV + 1 +* +* ==== Small-bulge multi-shift QR sweep ==== +* + CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, + $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, + $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, + $ NHO, H( KU, KWH ), LDH ) + END IF +* +* ==== Note progress (or the lack of it). ==== +* + IF( LD.GT.0 ) THEN + NDFL = 1 + ELSE + NDFL = NDFL + 1 + END IF +* +* ==== End of main loop ==== + 70 CONTINUE +* +* ==== Iteration limit exceeded. Set INFO to show where +* . the problem occurred and exit. ==== +* + INFO = KBOT + 80 CONTINUE + END IF +* +* ==== Return the optimal value of LWORK. ==== +* + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) +* +* ==== End of ZLAQR0 ==== +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlaqr0} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlaqr1 LAPACK} +%\pagehead{zlaqr1}{zlaqr1} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlaqr1.input} +)set break resume +)sys rm -f zlaqr1.output +)spool zlaqr1.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlaqr1.help} +==================================================================== +zlaqr1 examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V ) + + .. Scalar Arguments .. + COMPLEX*16 S1, S2 + INTEGER LDH, N + .. + .. Array Arguments .. + COMPLEX*16 H( LDH, * ), V( * ) + .. + + + Purpose: + ============= + + Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 sets v to a + scalar multiple of the first column of the product + + (*) K = (H - s1*I)*(H - s2*I) + + scaling to avoid overflows and most underflows. + + This is useful for starting double implicit shift bulges + in the QR algorithm. + + Arguments: + ========== + + [in] N + + N is integer + Order of the matrix H. N must be either 2 or 3. + + [in] H + + H is COMPLEX*16 array of dimension (LDH,N) + The 2-by-2 or 3-by-3 matrix H in (*). + + [in] LDH + + LDH is integer + The leading dimension of H as declared in + the calling procedure. LDH.GE.N + + [in] S1 + + S1 is COMPLEX*16 + + [in] S2 + + S2 is COMPLEX*16 + + S1 and S2 are the shifts defining K in (*) above. + + [out] V + + V is COMPLEX*16 array of dimension N + A scalar multiple of the first column of the + matrix K in (*). + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + + Contributors: + ================== + + Karen Braman and Ralph Byers, Department of Mathematics, + University of Kansas, USA + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + COMPLEX*16 S1, S2 + INTEGER LDH, N +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), V( * ) +* .. +* +* ================================================================ +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO + PARAMETER ( RZERO = 0.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 CDUM, H21S, H31S + DOUBLE PRECISION S +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. + IF( N.EQ.2 ) THEN + S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) + IF( S.EQ.RZERO ) THEN + V( 1 ) = ZERO + V( 2 ) = ZERO + ELSE + H21S = H( 2, 1 ) / S + V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-S1 )* + $ ( ( H( 1, 1 )-S2 ) / S ) + V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) + END IF + ELSE + S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) + + $ CABS1( H( 3, 1 ) ) + IF( S.EQ.ZERO ) THEN + V( 1 ) = ZERO + V( 2 ) = ZERO + V( 3 ) = ZERO + ELSE + H21S = H( 2, 1 ) / S + H31S = H( 3, 1 ) / S + V( 1 ) = ( H( 1, 1 )-S1 )*( ( H( 1, 1 )-S2 ) / S ) + + $ H( 1, 2 )*H21S + H( 1, 3 )*H31S + V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) + H( 2, 3 )*H31S + V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-S1-S2 ) + H21S*H( 3, 2 ) + END IF + END IF + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlaqr1} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlaqr2 LAPACK} +%\pagehead{zlaqr2}{zlaqr2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlaqr2.input} +)set break resume +)sys rm -f zlaqr2.output +)spool zlaqr2.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlaqr2.help} +==================================================================== +zlaqr2 examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, + NV, WV, LDWV, WORK, LWORK ) + + .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ + .. + .. Array Arguments .. + COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), + $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) + .. + + Purpose: + ============= + + ZLAQR2 is identical to ZLAQR3 except that it avoids + recursion by calling ZLAHQR instead of ZLAQR4. + + Aggressive early deflation: + + ZLAQR2 accepts as input an upper Hessenberg matrix + H and performs an unitary similarity transformation + designed to detect and deflate fully converged eigenvalues from + a trailing principal submatrix. On output H has been over- + written by a new Hessenberg matrix that is a perturbation of + an unitary similarity transformation of H. It is to be + hoped that the final version of H has many zero subdiagonal + entries. + + Arguments: + ========== + + [in] WANTT + + WANTT is LOGICAL + If .TRUE., then the Hessenberg matrix H is fully updated + so that the triangular Schur factor may be + computed (in cooperation with the calling subroutine). + If .FALSE., then only enough of H is updated to preserve + the eigenvalues. + + [in] WANTZ + + WANTZ is LOGICAL + If .TRUE., then the unitary matrix Z is updated so + so that the unitary Schur factor may be computed + (in cooperation with the calling subroutine). + If .FALSE., then Z is not referenced. + + [in] N + + N is INTEGER + The order of the matrix H and (if WANTZ is .TRUE.) the + order of the unitary matrix Z. + + [in] KTOP + + KTOP is INTEGER + It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. + KBOT and KTOP together determine an isolated block + along the diagonal of the Hessenberg matrix. + + [in] KBOT + + KBOT is INTEGER + It is assumed without a check that either + KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together + determine an isolated block along the diagonal of the + Hessenberg matrix. + + [in] NW + + NW is INTEGER + Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). + + [in,out] H + + H is COMPLEX*16 array, dimension (LDH,N) + On input the initial N-by-N section of H stores the + Hessenberg matrix undergoing aggressive early deflation. + On output H has been transformed by a unitary + similarity transformation, perturbed, and the returned + to Hessenberg form that (it is to be hoped) has some + zero subdiagonal entries. + + [in] LDH + + LDH is integer + Leading dimension of H just as declared in the calling + subroutine. N .LE. LDH + + [in] ILOZ + + ILOZ is INTEGER + + [in] IHIZ + + IHIZ is INTEGER + Specify the rows of Z to which transformations must be + applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. + + [in,out] Z + + Z is COMPLEX*16 array, dimension (LDZ,N) + IF WANTZ is .TRUE., then on output, the unitary + similarity transformation mentioned above has been + accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. + If WANTZ is .FALSE., then Z is unreferenced. + + [in] LDZ + + LDZ is integer + The leading dimension of Z just as declared in the + calling subroutine. 1 .LE. LDZ. + + [out] NS + + NS is integer + The number of unconverged (ie approximate) eigenvalues + returned in SR and SI that may be used as shifts by the + calling subroutine. + + [out] ND + + ND is integer + The number of converged eigenvalues uncovered by this + subroutine. + + [out] SH + + SH is COMPLEX*16 array, dimension KBOT + On output, approximate eigenvalues that may + be used for shifts are stored in SH(KBOT-ND-NS+1) + through SR(KBOT-ND). Converged eigenvalues are + stored in SH(KBOT-ND+1) through SH(KBOT). + + [out] V + + V is COMPLEX*16 array, dimension (LDV,NW) + An NW-by-NW work array. + + [in] LDV + + LDV is integer scalar + The leading dimension of V just as declared in the + calling subroutine. NW .LE. LDV + + [in] NH + + NH is integer scalar + The number of columns of T. NH.GE.NW. + + [out] T + + T is COMPLEX*16 array, dimension (LDT,NW) + + [in] LDT + + LDT is integer + The leading dimension of T just as declared in the + calling subroutine. NW .LE. LDT + + [in] NV + + NV is integer + The number of rows of work array WV available for + workspace. NV.GE.NW. + + [out] WV + + WV is COMPLEX*16 array, dimension (LDWV,NW) + + [in] LDWV + + LDWV is integer + The leading dimension of W just as declared in the + calling subroutine. NW .LE. LDV + + [out] WORK + + WORK is COMPLEX*16 array, dimension LWORK. + On exit, WORK(1) is set to an estimate of the optimal value + of LWORK for the given values of N, NW, KTOP and KBOT. + + [in] LWORK + + LWORK is integer + The dimension of the work array WORK. LWORK = 2*NW + suffices, but greater efficiency may result from larger + values of LWORK. + + If LWORK = -1, then a workspace query is assumed; ZLAQR2 + only estimates the optimal workspace size for the given + values of N, NW, KTOP and KBOT. The estimate is returned + in WORK(1). No error message related to LWORK is issued + by XERBLA. Neither H nor Z are accessed. + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + + Contributors: + ================== + + Karen Braman and Ralph Byers, Department of Mathematics, + University of Kansas, USA + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, + $ NV, WV, LDWV, WORK, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), + $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) +* .. +* +* ================================================================ +* +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE + PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 BETA, CDUM, S, TAU + DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, + $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, + $ ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNMHR +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to ZGEHRD ==== +* + CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to ZUNMHR ==== +* + CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + $ WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = JW + MAX( LWK1, LWK2 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + WORK( 1 ) = ONE + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Setup deflation window ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF +* + IF( KBOT.EQ.KWTOP ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + SH( KWTOP ) = H( KWTOP, KWTOP ) + NS = 1 + ND = 0 + IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, + $ KWTOP ) ) ) ) THEN + NS = 0 + ND = 1 + IF( KWTOP.GT.KTOP ) + $ H( KWTOP, KWTOP-1 ) = ZERO + END IF + WORK( 1 ) = ONE + RETURN + END IF +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) +* + CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, + $ JW, V, LDV, INFQR ) +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + DO 10 KNT = INFQR + 1, JW +* +* ==== Small spike tip deflation test ==== +* + FOO = CABS1( T( NS, NS ) ) + IF( FOO.EQ.RZERO ) + $ FOO = CABS1( S ) + IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) + $ THEN +* +* ==== One more converged eigenvalue ==== +* + NS = NS - 1 + ELSE +* +* ==== One undeflatable eigenvalue. Move it up out of the +* . way. (ZTREXC can not fail in this case.) ==== +* + IFST = NS + CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + ILST = ILST + 1 + END IF + 10 CONTINUE +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting the diagonal of T improves accuracy for +* . graded matrices. ==== +* + DO 30 I = INFQR + 1, NS + IFST = I + DO 20 J = I + 1, NS + IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) + $ IFST = J + 20 CONTINUE + ILST = I + IF( IFST.NE.ILST ) + $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + 30 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + DO 40 I = INFQR + 1, JW + SH( KWTOP+I-1 ) = T( I, I ) + 40 CONTINUE +* +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL ZCOPY( NS, V, LDV, WORK, 1 ) + DO 50 I = 1, NS + WORK( I ) = DCONJG( WORK( I ) ) + 50 CONTINUE + BETA = WORK( 1 ) + CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + WORK( 1 ) = ONE +* + CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) +* + CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) +* + CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) + CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. ==== +* + IF( NS.GT.1 .AND. S.NE.ZERO ) + $ CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ WORK( JW+1 ), LWORK-JW, INFO ) +* +* ==== Update vertical slab in H ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 60 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 60 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 70 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 70 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 80 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 80 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) +* +* ==== End of ZLAQR2 ==== +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlaqr2} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlaqr3 LAPACK} +%\pagehead{zlaqr3}{zlaqr3} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlaqr3.input} +)set break resume +)sys rm -f zlaqr3.output +)spool zlaqr3.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlaqr3.help} +==================================================================== +zlaqr3 examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, + NV, WV, LDWV, WORK, LWORK ) + + .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ + .. + .. Array Arguments .. + COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), + $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) + .. + + + Purpose: + ============= + + Aggressive early deflation: + + ZLAQR3 accepts as input an upper Hessenberg matrix + H and performs an unitary similarity transformation + designed to detect and deflate fully converged eigenvalues from + a trailing principal submatrix. On output H has been over- + written by a new Hessenberg matrix that is a perturbation of + an unitary similarity transformation of H. It is to be + hoped that the final version of H has many zero subdiagonal + entries. + + Arguments: + ========== + + [in] WANTT + + WANTT is LOGICAL + If .TRUE., then the Hessenberg matrix H is fully updated + so that the triangular Schur factor may be + computed (in cooperation with the calling subroutine). + If .FALSE., then only enough of H is updated to preserve + the eigenvalues. + + [in] WANTZ + + WANTZ is LOGICAL + If .TRUE., then the unitary matrix Z is updated so + so that the unitary Schur factor may be computed + (in cooperation with the calling subroutine). + If .FALSE., then Z is not referenced. + + [in] N + + N is INTEGER + The order of the matrix H and (if WANTZ is .TRUE.) the + order of the unitary matrix Z. + + [in] KTOP + + KTOP is INTEGER + It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. + KBOT and KTOP together determine an isolated block + along the diagonal of the Hessenberg matrix. + + [in] KBOT + + KBOT is INTEGER + It is assumed without a check that either + KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together + determine an isolated block along the diagonal of the + Hessenberg matrix. + + [in] NW + + NW is INTEGER + Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). + + [in,out] H + + H is COMPLEX*16 array, dimension (LDH,N) + On input the initial N-by-N section of H stores the + Hessenberg matrix undergoing aggressive early deflation. + On output H has been transformed by a unitary + similarity transformation, perturbed, and the returned + to Hessenberg form that (it is to be hoped) has some + zero subdiagonal entries. + + [in] LDH + + LDH is integer + Leading dimension of H just as declared in the calling + subroutine. N .LE. LDH + + [in] ILOZ + + ILOZ is INTEGER + + [in] IHIZ + + IHIZ is INTEGER + Specify the rows of Z to which transformations must be + applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. + + [in,out] Z + + Z is COMPLEX*16 array, dimension (LDZ,N) + IF WANTZ is .TRUE., then on output, the unitary + similarity transformation mentioned above has been + accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. + If WANTZ is .FALSE., then Z is unreferenced. + + [in] LDZ + + LDZ is integer + The leading dimension of Z just as declared in the + calling subroutine. 1 .LE. LDZ. + + [out] NS + + NS is integer + The number of unconverged (ie approximate) eigenvalues + returned in SR and SI that may be used as shifts by the + calling subroutine. + + [out] ND + + ND is integer + The number of converged eigenvalues uncovered by this + subroutine. + + [out] SH + + SH is COMPLEX*16 array, dimension KBOT + On output, approximate eigenvalues that may + be used for shifts are stored in SH(KBOT-ND-NS+1) + through SR(KBOT-ND). Converged eigenvalues are + stored in SH(KBOT-ND+1) through SH(KBOT). + + [out] V + + V is COMPLEX*16 array, dimension (LDV,NW) + An NW-by-NW work array. + + [in] LDV + + LDV is integer scalar + The leading dimension of V just as declared in the + calling subroutine. NW .LE. LDV + + [in] NH + + NH is integer scalar + The number of columns of T. NH.GE.NW. + + [out] T + + T is COMPLEX*16 array, dimension (LDT,NW) + + [in] LDT + + LDT is integer + The leading dimension of T just as declared in the + calling subroutine. NW .LE. LDT + + [in] NV + + NV is integer + The number of rows of work array WV available for + workspace. NV.GE.NW. + + [out] WV + + WV is COMPLEX*16 array, dimension (LDWV,NW) + + [in] LDWV + + LDWV is integer + The leading dimension of W just as declared in the + calling subroutine. NW .LE. LDV + + [out] WORK + + WORK is COMPLEX*16 array, dimension LWORK. + On exit, WORK(1) is set to an estimate of the optimal value + of LWORK for the given values of N, NW, KTOP and KBOT. + + [in] LWORK + + LWORK is integer + The dimension of the work array WORK. LWORK = 2*NW + suffices, but greater efficiency may result from larger + values of LWORK. + + If LWORK = -1, then a workspace query is assumed; ZLAQR3 + only estimates the optimal workspace size for the given + values of N, NW, KTOP and KBOT. The estimate is returned + in WORK(1). No error message related to LWORK is issued + by XERBLA. Neither H nor Z are accessed. + + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + + Contributors: + ================== + + Karen Braman and Ralph Byers, Department of Mathematics, + University of Kansas, USA + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, + $ NV, WV, LDWV, WORK, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), + $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) +* .. +* +* ================================================================ +* +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE + PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 BETA, CDUM, S, TAU + DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, + $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, + $ LWKOPT, NMIN +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER ILAENV + EXTERNAL DLAMCH, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, + $ ZLAQR4, ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNMHR +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to ZGEHRD ==== +* + CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to ZUNMHR ==== +* + CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + $ WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to ZLAQR4 ==== +* + CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, V, + $ LDV, WORK, -1, INFQR ) + LWK3 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + WORK( 1 ) = ONE + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Setup deflation window ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF +* + IF( KBOT.EQ.KWTOP ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + SH( KWTOP ) = H( KWTOP, KWTOP ) + NS = 1 + ND = 0 + IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, + $ KWTOP ) ) ) ) THEN + NS = 0 + ND = 1 + IF( KWTOP.GT.KTOP ) + $ H( KWTOP, KWTOP-1 ) = ZERO + END IF + WORK( 1 ) = ONE + RETURN + END IF +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) +* + CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + NMIN = ILAENV( 12, 'ZLAQR3', 'SV', JW, 1, JW, LWORK ) + IF( JW.GT.NMIN ) THEN + CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, + $ JW, V, LDV, WORK, LWORK, INFQR ) + ELSE + CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, + $ JW, V, LDV, INFQR ) + END IF +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + DO 10 KNT = INFQR + 1, JW +* +* ==== Small spike tip deflation test ==== +* + FOO = CABS1( T( NS, NS ) ) + IF( FOO.EQ.RZERO ) + $ FOO = CABS1( S ) + IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) + $ THEN +* +* ==== One more converged eigenvalue ==== +* + NS = NS - 1 + ELSE +* +* ==== One undeflatable eigenvalue. Move it up out of the +* . way. (ZTREXC can not fail in this case.) ==== +* + IFST = NS + CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + ILST = ILST + 1 + END IF + 10 CONTINUE +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting the diagonal of T improves accuracy for +* . graded matrices. ==== +* + DO 30 I = INFQR + 1, NS + IFST = I + DO 20 J = I + 1, NS + IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) + $ IFST = J + 20 CONTINUE + ILST = I + IF( IFST.NE.ILST ) + $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + 30 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + DO 40 I = INFQR + 1, JW + SH( KWTOP+I-1 ) = T( I, I ) + 40 CONTINUE +* +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL ZCOPY( NS, V, LDV, WORK, 1 ) + DO 50 I = 1, NS + WORK( I ) = DCONJG( WORK( I ) ) + 50 CONTINUE + BETA = WORK( 1 ) + CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU ) + WORK( 1 ) = ONE +* + CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) +* + CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) +* + CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) + CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. ==== +* + IF( NS.GT.1 .AND. S.NE.ZERO ) + $ CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ WORK( JW+1 ), LWORK-JW, INFO ) +* +* ==== Update vertical slab in H ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 60 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + 60 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 70 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 70 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 80 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 80 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) +* +* ==== End of ZLAQR3 ==== +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlaqr3} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlaqr4 LAPACK} +%\pagehead{zlaqr4}{zlaqr4} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlaqr4.input} +)set break resume +)sys rm -f zlaqr4.output +)spool zlaqr4.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlaqr4.help} +==================================================================== +zlaqr4 examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + IHIZ, Z, LDZ, WORK, LWORK, INFO ) + + .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ + .. + .. Array Arguments .. + COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) + .. + + + Purpose: + ============= + + ZLAQR4 implements one level of recursion for ZLAQR0. + It is a complete implementation of the small bulge multi-shift + QR algorithm. It may be called by ZLAQR0 and, for large enough + deflation window size, it may be called by ZLAQR3. This + subroutine is identical to ZLAQR0 except that it calls ZLAQR2 + instead of ZLAQR3. + + ZLAQR4 computes the eigenvalues of a Hessenberg matrix H + and, optionally, the matrices T and Z from the Schur decomposition + H = Z T Z**H, where T is an upper triangular matrix (the + Schur form), and Z is the unitary matrix of Schur vectors. + + Optionally Z may be postmultiplied into an input unitary + 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 unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. + + Arguments: + ========== + + [in] WANTT + + WANTT is LOGICAL + = .TRUE. : the full Schur form T is required; + = .FALSE.: only eigenvalues are required. + + [in] WANTZ + + WANTZ is LOGICAL + = .TRUE. : the matrix of Schur vectors Z is required; + = .FALSE.: Schur vectors are not required. + + [in] N + + N is INTEGER + The order of the matrix H. N .GE. 0. + + [in] ILO + + ILO is INTEGER + + [in] IHI + + IHI is INTEGER + It is assumed that H is already upper triangular in rows + and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, + H(ILO,ILO-1) is zero. ILO and IHI are normally set by a + previous call to ZGEBAL, and then passed to ZGEHRD when the + matrix output by ZGEBAL is reduced to Hessenberg form. + Otherwise, ILO and IHI should be set to 1 and N, + respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. + If N = 0, then ILO = 1 and IHI = 0. + + [in,out] H + + H is COMPLEX*16 array, dimension (LDH,N) + On entry, the upper Hessenberg matrix H. + On exit, if INFO = 0 and WANTT is .TRUE., then H + contains the upper triangular matrix T from the Schur + decomposition (the Schur form). If INFO = 0 and WANT is + .FALSE., then the contents of H are unspecified on exit. + (The output value of H when INFO.GT.0 is given under the + description of INFO below.) + + This subroutine may explicitly set H(i,j) = 0 for i.GT.j and + j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. + + [in] LDH + + LDH is INTEGER + The leading dimension of the array H. LDH .GE. max(1,N). + + [out] W + + W is COMPLEX*16 array, dimension (N) + The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored + in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are + stored in the same order as on the diagonal of the Schur + form returned in H, with W(i) = H(i,i). + + [in] ILOZ + + ILOZ is INTEGER + + [in] IHIZ + + IHIZ is INTEGER + Specify the rows of Z to which transformations must be + applied if WANTZ is .TRUE.. + 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. + + [in,out] Z + + Z is COMPLEX*16 array, dimension (LDZ,IHI) + If WANTZ is .FALSE., then Z is not referenced. + If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is + replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the + orthogonal Schur factor of H(ILO:IHI,ILO:IHI). + (The output value of Z when INFO.GT.0 is given under + the description of INFO below.) + + [in] LDZ + + LDZ is INTEGER + The leading dimension of the array Z. if WANTZ is .TRUE. + then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. + + [out] WORK + + WORK is COMPLEX*16 array, dimension LWORK + On exit, if LWORK = -1, WORK(1) returns an estimate of + the optimal value for LWORK. + + [in] LWORK + + LWORK is INTEGER + The dimension of the array WORK. LWORK .GE. max(1,N) + is sufficient, but LWORK typically as large as 6*N may + be required for optimal performance. A workspace query + to determine the optimal workspace size is recommended. + + If LWORK = -1, then ZLAQR4 does a workspace query. + In this case, ZLAQR4 checks the input parameters and + estimates the optimal workspace size for the given + values of N, ILO and IHI. The estimate is returned + in WORK(1). No error message related to LWORK is + issued by XERBLA. Neither H nor Z are accessed. + + [out] INFO + + INFO is INTEGER + = 0: successful exit + .GT. 0: if INFO = i, ZLAQR4 failed to compute all of + the eigenvalues. Elements 1:ilo-1 and i+1:n of WR + and WI contain those eigenvalues which have been + successfully computed. (Failures are rare.) + + If INFO .GT. 0 and WANT is .FALSE., then on exit, + the remaining unconverged eigenvalues are the eigen- + values of the upper Hessenberg matrix rows and + columns ILO through INFO of the final, output + value of H. + + If INFO .GT. 0 and WANTT is .TRUE., then on exit + + (*) (initial value of H)*U = U*(final value of H) + + where U is a unitary matrix. The final + value of H is upper Hessenberg and triangular in + rows and columns INFO+1 through IHI. + + If INFO .GT. 0 and WANTZ is .TRUE., then on exit + + (final value of Z(ILO:IHI,ILOZ:IHIZ) + = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U + + where U is the unitary matrix in (*) (regard- + less of the value of WANTT.) + + If INFO .GT. 0 and WANTZ is .FALSE., then Z is not + accessed. + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + + Contributors: + ================== + + Karen Braman and Ralph Byers, Department of Mathematics, + University of Kansas, USA + + References: + ================ + + K. Braman, R. Byers and R. Mathias, The Multi-Shift QR + Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 + Performance, SIAM Journal of Matrix Analysis, volume 23, pages + 929--947, 2002. + + K. Braman, R. Byers and R. Mathias, The Multi-Shift QR + Algorithm Part II: Aggressive Early Deflation, SIAM Journal + of Matrix Analysis, volume 23, pages 948--973, 2002. + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* ================================================================ +* +* .. Parameters .. +* +* ==== Matrices of order NTINY or smaller must be processed by +* . ZLAHQR because of insufficient subdiagonal scratch space. +* . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) +* +* ==== Exceptional deflation windows: try to cure rare +* . slow convergence by varying the size of the +* . deflation window after KEXNW iterations. ==== + INTEGER KEXNW + PARAMETER ( KEXNW = 5 ) +* +* ==== Exceptional shifts: try to cure rare slow convergence +* . with ad-hoc exceptional shifts every KEXSH iterations. +* . ==== + INTEGER KEXSH + PARAMETER ( KEXSH = 6 ) +* +* ==== The constant WILK1 is used to form the exceptional +* . shifts. ==== + DOUBLE PRECISION WILK1 + PARAMETER ( WILK1 = 0.75d0 ) + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 + DOUBLE PRECISION S + INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, + $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, + $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, + $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD + LOGICAL SORTED + CHARACTER JBCMPZ*2 +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Local Arrays .. + COMPLEX*16 ZDUM( 1, 1 ) +* .. +* .. External Subroutines .. + EXTERNAL ZLACPY, ZLAHQR, ZLAQR2, ZLAQR5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, + $ SQRT +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. + INFO = 0 +* +* ==== Quick return for N = 0: nothing to do. ==== +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = ONE + RETURN + END IF +* + IF( N.LE.NTINY ) THEN +* +* ==== Tiny matrices must use ZLAHQR. ==== +* + LWKOPT = 1 + IF( LWORK.NE.-1 ) + $ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, + $ IHIZ, Z, LDZ, INFO ) + ELSE +* +* ==== Use small bulge multi-shift QR with aggressive early +* . deflation on larger-than-tiny matrices. ==== +* +* ==== Hope for the best. ==== +* + INFO = 0 +* +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* +* ==== NWR = recommended deflation window size. At this +* . point, N .GT. NTINY = 11, so there is enough +* . subdiagonal workspace for NWR.GE.2 as required. +* . (In fact, there is enough subdiagonal space for +* . NWR.GE.3.) ==== +* + NWR = ILAENV( 13, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NWR = MAX( 2, NWR ) + NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) +* +* ==== NSR = recommended number of simultaneous shifts. +* . At this point N .GT. NTINY = 11, so there is at +* . enough subdiagonal workspace for NSR to be even +* . and greater than or equal to two as required. ==== +* + NSR = ILAENV( 15, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) + NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) +* +* ==== Estimate optimal workspace ==== +* +* ==== Workspace query call to ZLAQR2 ==== +* + CALL ZLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, + $ LDH, WORK, -1 ) +* +* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR2) ==== +* + LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF +* +* ==== ZLAHQR/ZLAQR0 crossover point ==== +* + NMIN = ILAENV( 12, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NMIN = MAX( NTINY, NMIN ) +* +* ==== Nibble crossover point ==== +* + NIBBLE = ILAENV( 14, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + NIBBLE = MAX( 0, NIBBLE ) +* +* ==== Accumulate reflections during ttswp? Use block +* . 2-by-2 structure during matrix-matrix multiply? ==== +* + KACC22 = ILAENV( 16, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) + KACC22 = MAX( 0, KACC22 ) + KACC22 = MIN( 2, KACC22 ) +* +* ==== NWMAX = the largest possible deflation window for +* . which there is sufficient workspace. ==== +* + NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) + NW = NWMAX +* +* ==== NSMAX = the Largest number of simultaneous shifts +* . for which there is sufficient workspace. ==== +* + NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) + NSMAX = NSMAX - MOD( NSMAX, 2 ) +* +* ==== NDFL: an iteration count restarted at deflation. ==== +* + NDFL = 1 +* +* ==== ITMAX = iteration limit ==== +* + ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) +* +* ==== Last row and column in the active block ==== +* + KBOT = IHI +* +* ==== Main Loop ==== +* + DO 70 IT = 1, ITMAX +* +* ==== Done when KBOT falls below ILO ==== +* + IF( KBOT.LT.ILO ) + $ GO TO 80 +* +* ==== Locate active block ==== +* + DO 10 K = KBOT, ILO + 1, -1 + IF( H( K, K-1 ).EQ.ZERO ) + $ GO TO 20 + 10 CONTINUE + K = ILO + 20 CONTINUE + KTOP = K +* +* ==== Select deflation window size: +* . Typical Case: +* . If possible and advisable, nibble the entire +* . active block. If not, use size MIN(NWR,NWMAX) +* . or MIN(NWR+1,NWMAX) depending upon which has +* . the smaller corresponding subdiagonal entry +* . (a heuristic). +* . +* . Exceptional Case: +* . If there have been no deflations in KEXNW or +* . more iterations, then vary the deflation window +* . size. At first, because, larger windows are, +* . in general, more powerful than smaller ones, +* . rapidly increase the window to the maximum possible. +* . Then, gradually reduce the window size. ==== +* + NH = KBOT - KTOP + 1 + NWUPBD = MIN( NH, NWMAX ) + IF( NDFL.LT.KEXNW ) THEN + NW = MIN( NWUPBD, NWR ) + ELSE + NW = MIN( NWUPBD, 2*NW ) + END IF + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH + ELSE + KWTOP = KBOT - NW + 1 + IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. + $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 + END IF + END IF + IF( NDFL.LT.KEXNW ) THEN + NDEC = -1 + ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN + NDEC = NDEC + 1 + IF( NW-NDEC.LT.2 ) + $ NDEC = 0 + NW = NW - NDEC + END IF +* +* ==== Aggressive early deflation: +* . split workspace under the subdiagonal into +* . - an nw-by-nw work array V in the lower +* . left-hand-corner, +* . - an NW-by-at-least-NW-but-more-is-better +* . (NW-by-NHO) horizontal work array along +* . the bottom edge, +* . - an at-least-NW-but-more-is-better (NHV-by-NW) +* . vertical work array along the left-hand-edge. +* . ==== +* + KV = N - NW + 1 + KT = NW + 1 + NHO = ( N-NW-1 ) - KT + 1 + KWV = NW + 2 + NVE = ( N-NW ) - KWV + 1 +* +* ==== Aggressive early deflation ==== +* + CALL ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, + $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, + $ LWORK ) +* +* ==== Adjust KBOT accounting for new deflations. ==== +* + KBOT = KBOT - LD +* +* ==== KS points to the shifts. ==== +* + KS = KBOT - LS + 1 +* +* ==== Skip an expensive QR sweep if there is a (partly +* . heuristic) reason to expect that many eigenvalues +* . will deflate without it. Here, the QR sweep is +* . skipped if many eigenvalues have just been deflated +* . or if the remaining active block is small. +* + IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- + $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN +* +* ==== NS = nominal number of simultaneous shifts. +* . This may be lowered (slightly) if ZLAQR2 +* . did not provide that many shifts. ==== +* + NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) + NS = NS - MOD( NS, 2 ) +* +* ==== If there have been no deflations +* . in a multiple of KEXSH iterations, +* . then try exceptional shifts. +* . Otherwise use shifts provided by +* . ZLAQR2 above or from the eigenvalues +* . of a trailing principal submatrix. ==== +* + IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN + KS = KBOT - NS + 1 + DO 30 I = KBOT, KS + 1, -2 + W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) + W( I-1 ) = W( I ) + 30 CONTINUE + ELSE +* +* ==== Got NS/2 or fewer shifts? Use ZLAHQR +* . on a trailing principal submatrix to +* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, +* . there is enough space below the subdiagonal +* . to fit an NS-by-NS scratch array.) ==== +* + IF( KBOT-KS+1.LE.NS / 2 ) THEN + KS = KBOT - NS + 1 + KT = N - NS + 1 + CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH, + $ H( KT, 1 ), LDH ) + CALL ZLAHQR( .false., .false., NS, 1, NS, + $ H( KT, 1 ), LDH, W( KS ), 1, 1, ZDUM, + $ 1, INF ) + KS = KS + INF +* +* ==== In case of a rare QR failure use +* . eigenvalues of the trailing 2-by-2 +* . principal submatrix. Scale to avoid +* . overflows, underflows and subnormals. +* . (The scale factor S can not be zero, +* . because H(KBOT,KBOT-1) is nonzero.) ==== +* + IF( KS.GE.KBOT ) THEN + S = CABS1( H( KBOT-1, KBOT-1 ) ) + + $ CABS1( H( KBOT, KBOT-1 ) ) + + $ CABS1( H( KBOT-1, KBOT ) ) + + $ CABS1( H( KBOT, KBOT ) ) + AA = H( KBOT-1, KBOT-1 ) / S + CC = H( KBOT, KBOT-1 ) / S + BB = H( KBOT-1, KBOT ) / S + DD = H( KBOT, KBOT ) / S + TR2 = ( AA+DD ) / TWO + DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC + RTDISC = SQRT( -DET ) + W( KBOT-1 ) = ( TR2+RTDISC )*S + W( KBOT ) = ( TR2-RTDISC )*S +* + KS = KBOT - 1 + END IF + END IF +* + IF( KBOT-KS+1.GT.NS ) THEN +* +* ==== Sort the shifts (Helps a little) ==== +* + SORTED = .false. + DO 50 K = KBOT, KS + 1, -1 + IF( SORTED ) + $ GO TO 60 + SORTED = .true. + DO 40 I = KS, K - 1 + IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) + $ THEN + SORTED = .false. + SWAP = W( I ) + W( I ) = W( I+1 ) + W( I+1 ) = SWAP + END IF + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + END IF + END IF +* +* ==== If there are only two shifts, then use +* . only one. ==== +* + IF( KBOT-KS+1.EQ.2 ) THEN + IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. + $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN + W( KBOT-1 ) = W( KBOT ) + ELSE + W( KBOT ) = W( KBOT-1 ) + END IF + END IF +* +* ==== Use up to NS of the the smallest magnatiude +* . shifts. If there aren't NS shifts available, +* . then use them all, possibly dropping one to +* . make the number of shifts even. ==== +* + NS = MIN( NS, KBOT-KS+1 ) + NS = NS - MOD( NS, 2 ) + KS = KBOT - NS + 1 +* +* ==== Small-bulge multi-shift QR sweep: +* . split workspace under the subdiagonal into +* . - a KDU-by-KDU work array U in the lower +* . left-hand-corner, +* . - a KDU-by-at-least-KDU-but-more-is-better +* . (KDU-by-NHo) horizontal work array WH along +* . the bottom edge, +* . - and an at-least-KDU-but-more-is-better-by-KDU +* . (NVE-by-KDU) vertical work WV arrow along +* . the left-hand-edge. ==== +* + KDU = 3*NS - 3 + KU = N - KDU + 1 + KWH = KDU + 1 + NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 + KWV = KDU + 4 + NVE = N - KDU - KWV + 1 +* +* ==== Small-bulge multi-shift QR sweep ==== +* + CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, + $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, + $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, + $ NHO, H( KU, KWH ), LDH ) + END IF +* +* ==== Note progress (or the lack of it). ==== +* + IF( LD.GT.0 ) THEN + NDFL = 1 + ELSE + NDFL = NDFL + 1 + END IF +* +* ==== End of main loop ==== + 70 CONTINUE +* +* ==== Iteration limit exceeded. Set INFO to show where +* . the problem occurred and exit. ==== +* + INFO = KBOT + 80 CONTINUE + END IF +* +* ==== Return the optimal value of LWORK. ==== +* + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) +* +* ==== End of ZLAQR4 ==== +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlaqr4} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlaqr5 LAPACK} +%\pagehead{zlaqr5}{zlaqr5} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlaqr5.input} +)set break resume +)sys rm -f zlaqr5.output +)spool zlaqr5.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlaqr5.help} +==================================================================== +zlaqr5 examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, + H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, + WV, LDWV, NH, WH, LDWH ) + + .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, + $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV + LOGICAL WANTT, WANTZ + .. + .. Array Arguments .. + COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ), + $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * ) + .. + + + Purpose: + ============= + + ZLAQR5, called by ZLAQR0, performs a + single small-bulge multi-shift QR sweep. + + Arguments: + ========== + + [in] WANTT + + WANTT is logical scalar + WANTT = .true. if the triangular Schur factor + is being computed. WANTT is set to .false. otherwise. + + [in] WANTZ + + WANTZ is logical scalar + WANTZ = .true. if the unitary Schur factor is being + computed. WANTZ is set to .false. otherwise. + + [in] KACC22 + + KACC22 is integer with value 0, 1, or 2. + Specifies the computation mode of far-from-diagonal + orthogonal updates. + = 0: ZLAQR5 does not accumulate reflections and does not + use matrix-matrix multiply to update far-from-diagonal + matrix entries. + = 1: ZLAQR5 accumulates reflections and uses matrix-matrix + multiply to update the far-from-diagonal matrix entries. + = 2: ZLAQR5 accumulates reflections, uses matrix-matrix + multiply to update the far-from-diagonal matrix entries, + and takes advantage of 2-by-2 block structure during + matrix multiplies. + + [in] N + + N is integer scalar + N is the order of the Hessenberg matrix H upon which this + subroutine operates. + + [in] KTOP + + KTOP is integer scalar + + [in] KBOT + + KBOT is integer scalar + These are the first and last rows and columns of an + isolated diagonal block upon which the QR sweep is to be + applied. It is assumed without a check that + either KTOP = 1 or H(KTOP,KTOP-1) = 0 + and + either KBOT = N or H(KBOT+1,KBOT) = 0. + + [in] NSHFTS + + NSHFTS is integer scalar + NSHFTS gives the number of simultaneous shifts. NSHFTS + must be positive and even. + + [in,out] S + + S is COMPLEX*16 array of size (NSHFTS) + S contains the shifts of origin that define the multi- + shift QR sweep. On output S may be reordered. + + [in,out] H + + H is COMPLEX*16 array of size (LDH,N) + On input H contains a Hessenberg matrix. On output a + multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied + to the isolated diagonal block in rows and columns KTOP + through KBOT. + + [in] LDH + + LDH is integer scalar + LDH is the leading dimension of H just as declared in the + calling procedure. LDH.GE.MAX(1,N). + + [in] ILOZ + + ILOZ is INTEGER + + [in] IHIZ + + IHIZ is INTEGER + Specify the rows of Z to which transformations must be + applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N + + [in,out] Z + + Z is COMPLEX*16 array of size (LDZ,IHI) + If WANTZ = .TRUE., then the QR Sweep unitary + similarity transformation is accumulated into + Z(ILOZ:IHIZ,ILO:IHI) from the right. + If WANTZ = .FALSE., then Z is unreferenced. + + [in] LDZ + + LDZ is integer scalar + LDA is the leading dimension of Z just as declared in + the calling procedure. LDZ.GE.N. + + [out] V + + V is COMPLEX*16 array of size (LDV,NSHFTS/2) + + [in] LDV + + LDV is integer scalar + LDV is the leading dimension of V as declared in the + calling procedure. LDV.GE.3. + + [out] U + + U is COMPLEX*16 array of size + (LDU,3*NSHFTS-3) + + [in] LDU + + LDU is integer scalar + LDU is the leading dimension of U just as declared in the + in the calling subroutine. LDU.GE.3*NSHFTS-3. + + [in] NH + + NH is integer scalar + NH is the number of columns in array WH available for + workspace. NH.GE.1. + + [out] WH + + WH is COMPLEX*16 array of size (LDWH,NH) + + [in] LDWH + + LDWH is integer scalar + Leading dimension of WH just as declared in the + calling procedure. LDWH.GE.3*NSHFTS-3. + + [in] NV + + NV is integer scalar + NV is the number of rows in WV agailable for workspace. + NV.GE.1. + + [out] WV + + WV is COMPLEX*16 array of size + (LDWV,3*NSHFTS-3) + + [in] LDWV + + LDWV is integer scalar + LDWV is the leading dimension of WV as declared in the + in the calling subroutine. LDWV.GE.NV. + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + + Contributors: + ================== + + Karen Braman and Ralph Byers, Department of Mathematics, + University of Kansas, USA + + References: + ================ + + K. Braman, R. Byers and R. Mathias, The Multi-Shift QR + Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 + Performance, SIAM Journal of Matrix Analysis, volume 23, pages + 929--947, 2002. + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, + $ H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, + $ WV, LDWV, NH, WH, LDWH ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, + $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ), + $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * ) +* .. +* +* ================================================================ +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE + PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 ALPHA, BETA, CDUM, REFSUM + DOUBLE PRECISION H11, H12, H21, H22, SAFMAX, SAFMIN, SCL, + $ SMLNUM, TST1, TST2, ULP + INTEGER I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN, + $ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS, + $ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL, + $ NS, NU + LOGICAL ACCUM, BLK22, BMP22 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. +* + INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD +* .. +* .. Local Arrays .. + COMPLEX*16 VT( 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DLABAD, ZGEMM, ZLACPY, ZLAQR1, ZLARFG, ZLASET, + $ ZTRMM +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* ==== If there are no shifts, then there is nothing to do. ==== +* + IF( NSHFTS.LT.2 ) + $ RETURN +* +* ==== If the active block is empty or 1-by-1, then there +* . is nothing to do. ==== +* + IF( KTOP.GE.KBOT ) + $ RETURN +* +* ==== NSHFTS is supposed to be even, but if it is odd, +* . then simply reduce it by one. ==== +* + NS = NSHFTS - MOD( NSHFTS, 2 ) +* +* ==== Machine constants for deflation ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Use accumulated reflections to update far-from-diagonal +* . entries ? ==== +* + ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 ) +* +* ==== If so, exploit the 2-by-2 block structure? ==== +* + BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 ) +* +* ==== clear trash ==== +* + IF( KTOP+2.LE.KBOT ) + $ H( KTOP+2, KTOP ) = ZERO +* +* ==== NBMPS = number of 2-shift bulges in the chain ==== +* + NBMPS = NS / 2 +* +* ==== KDU = width of slab ==== +* + KDU = 6*NBMPS - 3 +* +* ==== Create and chase chains of NBMPS bulges ==== +* + DO 210 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2 + NDCOL = INCOL + KDU + IF( ACCUM ) + $ CALL ZLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU ) +* +* ==== Near-the-diagonal bulge chase. The following loop +* . performs the near-the-diagonal part of a small bulge +* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal +* . chunk extends from column INCOL to column NDCOL +* . (including both column INCOL and column NDCOL). The +* . following loop chases a 3*NBMPS column long chain of +* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL +* . may be less than KTOP and and NDCOL may be greater than +* . KBOT indicating phantom columns from which to chase +* . bulges before they are actually introduced or to which +* . to chase bulges beyond column KBOT.) ==== +* + DO 140 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 ) +* +* ==== Bulges number MTOP to MBOT are active double implicit +* . shift bulges. There may or may not also be small +* . 2-by-2 bulge, if there is room. The inactive bulges +* . (if any) must wait until the active bulges have moved +* . down the diagonal to make room. The phantom matrix +* . paradigm described above helps keep track. ==== +* + MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 ) + MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 ) + M22 = MBOT + 1 + BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ. + $ ( KBOT-2 ) +* +* ==== Generate reflections to chase the chain right +* . one column. (The minimum value of K is KTOP-1.) ==== +* + DO 10 M = MTOP, MBOT + K = KRCOL + 3*( M-1 ) + IF( K.EQ.KTOP-1 ) THEN + CALL ZLAQR1( 3, H( KTOP, KTOP ), LDH, S( 2*M-1 ), + $ S( 2*M ), V( 1, M ) ) + ALPHA = V( 1, M ) + CALL ZLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) ) + ELSE + BETA = H( K+1, K ) + V( 2, M ) = H( K+2, K ) + V( 3, M ) = H( K+3, K ) + CALL ZLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) +* +* ==== A Bulge may collapse because of vigilant +* . deflation or destructive underflow. In the +* . underflow case, try the two-small-subdiagonals +* . trick to try to reinflate the bulge. ==== +* + IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE. + $ ZERO .OR. H( K+3, K+2 ).EQ.ZERO ) THEN +* +* ==== Typical case: not collapsed (yet). ==== +* + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + ELSE +* +* ==== Atypical case: collapsed. Attempt to +* . reintroduce ignoring H(K+1,K) and H(K+2,K). +* . If the fill resulting from the new +* . reflector is too large, then abandon it. +* . Otherwise, use the new one. ==== +* + CALL ZLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ), + $ S( 2*M ), VT ) + ALPHA = VT( 1 ) + CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) + REFSUM = DCONJG( VT( 1 ) )* + $ ( H( K+1, K )+DCONJG( VT( 2 ) )* + $ H( K+2, K ) ) +* + IF( CABS1( H( K+2, K )-REFSUM*VT( 2 ) )+ + $ CABS1( REFSUM*VT( 3 ) ).GT.ULP* + $ ( CABS1( H( K, K ) )+CABS1( H( K+1, + $ K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN +* +* ==== Starting a new bulge here would +* . create non-negligible fill. Use +* . the old one with trepidation. ==== +* + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + ELSE +* +* ==== Stating a new bulge here would +* . create only negligible fill. +* . Replace the old reflector with +* . the new one. ==== +* + H( K+1, K ) = H( K+1, K ) - REFSUM + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO + V( 1, M ) = VT( 1 ) + V( 2, M ) = VT( 2 ) + V( 3, M ) = VT( 3 ) + END IF + END IF + END IF + 10 CONTINUE +* +* ==== Generate a 2-by-2 reflection, if needed. ==== +* + K = KRCOL + 3*( M22-1 ) + IF( BMP22 ) THEN + IF( K.EQ.KTOP-1 ) THEN + CALL ZLAQR1( 2, H( K+1, K+1 ), LDH, S( 2*M22-1 ), + $ S( 2*M22 ), V( 1, M22 ) ) + BETA = V( 1, M22 ) + CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) + ELSE + BETA = H( K+1, K ) + V( 2, M22 ) = H( K+2, K ) + CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + END IF + END IF +* +* ==== Multiply H by reflections from the left ==== +* + IF( ACCUM ) THEN + JBOT = MIN( NDCOL, KBOT ) + ELSE IF( WANTT ) THEN + JBOT = N + ELSE + JBOT = KBOT + END IF + DO 30 J = MAX( KTOP, KRCOL ), JBOT + MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 ) + DO 20 M = MTOP, MEND + K = KRCOL + 3*( M-1 ) + REFSUM = DCONJG( V( 1, M ) )* + $ ( H( K+1, J )+DCONJG( V( 2, M ) )* + $ H( K+2, J )+DCONJG( V( 3, M ) )*H( K+3, J ) ) + H( K+1, J ) = H( K+1, J ) - REFSUM + H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M ) + H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M ) + 20 CONTINUE + 30 CONTINUE + IF( BMP22 ) THEN + K = KRCOL + 3*( M22-1 ) + DO 40 J = MAX( K+1, KTOP ), JBOT + REFSUM = DCONJG( V( 1, M22 ) )* + $ ( H( K+1, J )+DCONJG( V( 2, M22 ) )* + $ H( K+2, J ) ) + H( K+1, J ) = H( K+1, J ) - REFSUM + H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 ) + 40 CONTINUE + END IF +* +* ==== Multiply H by reflections from the right. +* . Delay filling in the last row until the +* . vigilant deflation check is complete. ==== +* + IF( ACCUM ) THEN + JTOP = MAX( KTOP, INCOL ) + ELSE IF( WANTT ) THEN + JTOP = 1 + ELSE + JTOP = KTOP + END IF + DO 80 M = MTOP, MBOT + IF( V( 1, M ).NE.ZERO ) THEN + K = KRCOL + 3*( M-1 ) + DO 50 J = JTOP, MIN( KBOT, K+3 ) + REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )* + $ H( J, K+2 )+V( 3, M )*H( J, K+3 ) ) + H( J, K+1 ) = H( J, K+1 ) - REFSUM + H( J, K+2 ) = H( J, K+2 ) - + $ REFSUM*DCONJG( V( 2, M ) ) + H( J, K+3 ) = H( J, K+3 ) - + $ REFSUM*DCONJG( V( 3, M ) ) + 50 CONTINUE +* + IF( ACCUM ) THEN +* +* ==== Accumulate U. (If necessary, update Z later +* . with with an efficient matrix-matrix +* . multiply.) ==== +* + KMS = K - INCOL + DO 60 J = MAX( 1, KTOP-INCOL ), KDU + REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )* + $ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) ) + U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM + U( J, KMS+2 ) = U( J, KMS+2 ) - + $ REFSUM*DCONJG( V( 2, M ) ) + U( J, KMS+3 ) = U( J, KMS+3 ) - + $ REFSUM*DCONJG( V( 3, M ) ) + 60 CONTINUE + ELSE IF( WANTZ ) THEN +* +* ==== U is not accumulated, so update Z +* . now by multiplying by reflections +* . from the right. ==== +* + DO 70 J = ILOZ, IHIZ + REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )* + $ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) ) + Z( J, K+1 ) = Z( J, K+1 ) - REFSUM + Z( J, K+2 ) = Z( J, K+2 ) - + $ REFSUM*DCONJG( V( 2, M ) ) + Z( J, K+3 ) = Z( J, K+3 ) - + $ REFSUM*DCONJG( V( 3, M ) ) + 70 CONTINUE + END IF + END IF + 80 CONTINUE +* +* ==== Special case: 2-by-2 reflection (if needed) ==== +* + K = KRCOL + 3*( M22-1 ) + IF( BMP22 ) THEN + IF ( V( 1, M22 ).NE.ZERO ) THEN + DO 90 J = JTOP, MIN( KBOT, K+3 ) + REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )* + $ H( J, K+2 ) ) + H( J, K+1 ) = H( J, K+1 ) - REFSUM + H( J, K+2 ) = H( J, K+2 ) - + $ REFSUM*DCONJG( V( 2, M22 ) ) + 90 CONTINUE +* + IF( ACCUM ) THEN + KMS = K - INCOL + DO 100 J = MAX( 1, KTOP-INCOL ), KDU + REFSUM = V( 1, M22 )*( U( J, KMS+1 )+ + $ V( 2, M22 )*U( J, KMS+2 ) ) + U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM + U( J, KMS+2 ) = U( J, KMS+2 ) - + $ REFSUM*DCONJG( V( 2, M22 ) ) + 100 CONTINUE + ELSE IF( WANTZ ) THEN + DO 110 J = ILOZ, IHIZ + REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )* + $ Z( J, K+2 ) ) + Z( J, K+1 ) = Z( J, K+1 ) - REFSUM + Z( J, K+2 ) = Z( J, K+2 ) - + $ REFSUM*DCONJG( V( 2, M22 ) ) + 110 CONTINUE + END IF + END IF + END IF +* +* ==== Vigilant deflation check ==== +* + MSTART = MTOP + IF( KRCOL+3*( MSTART-1 ).LT.KTOP ) + $ MSTART = MSTART + 1 + MEND = MBOT + IF( BMP22 ) + $ MEND = MEND + 1 + IF( KRCOL.EQ.KBOT-2 ) + $ MEND = MEND + 1 + DO 120 M = MSTART, MEND + K = MIN( KBOT-1, KRCOL+3*( M-1 ) ) +* +* ==== The following convergence test requires that +* . the tradition small-compared-to-nearby-diagonals +* . criterion and the Ahues & Tisseur (LAWN 122, 1997) +* . criteria both be satisfied. The latter improves +* . accuracy in some examples. Falling back on an +* . alternate convergence criterion when TST1 or TST2 +* . is zero (as done here) is traditional but probably +* . unnecessary. ==== +* + IF( H( K+1, K ).NE.ZERO ) THEN + TST1 = CABS1( H( K, K ) ) + CABS1( H( K+1, K+1 ) ) + IF( TST1.EQ.RZERO ) THEN + IF( K.GE.KTOP+1 ) + $ TST1 = TST1 + CABS1( H( K, K-1 ) ) + IF( K.GE.KTOP+2 ) + $ TST1 = TST1 + CABS1( H( K, K-2 ) ) + IF( K.GE.KTOP+3 ) + $ TST1 = TST1 + CABS1( H( K, K-3 ) ) + IF( K.LE.KBOT-2 ) + $ TST1 = TST1 + CABS1( H( K+2, K+1 ) ) + IF( K.LE.KBOT-3 ) + $ TST1 = TST1 + CABS1( H( K+3, K+1 ) ) + IF( K.LE.KBOT-4 ) + $ TST1 = TST1 + CABS1( H( K+4, K+1 ) ) + END IF + IF( CABS1( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) ) + $ THEN + H12 = MAX( CABS1( H( K+1, K ) ), + $ CABS1( H( K, K+1 ) ) ) + H21 = MIN( CABS1( H( K+1, K ) ), + $ CABS1( H( K, K+1 ) ) ) + H11 = MAX( CABS1( H( K+1, K+1 ) ), + $ CABS1( H( K, K )-H( K+1, K+1 ) ) ) + H22 = MIN( CABS1( H( K+1, K+1 ) ), + $ CABS1( H( K, K )-H( K+1, K+1 ) ) ) + SCL = H11 + H12 + TST2 = H22*( H11 / SCL ) +* + IF( TST2.EQ.RZERO .OR. H21*( H12 / SCL ).LE. + $ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO + END IF + END IF + 120 CONTINUE +* +* ==== Fill in the last row of each bulge. ==== +* + MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 ) + DO 130 M = MTOP, MEND + K = KRCOL + 3*( M-1 ) + REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 ) + H( K+4, K+1 ) = -REFSUM + H( K+4, K+2 ) = -REFSUM*DCONJG( V( 2, M ) ) + H( K+4, K+3 ) = H( K+4, K+3 ) - + $ REFSUM*DCONJG( V( 3, M ) ) + 130 CONTINUE +* +* ==== End of near-the-diagonal bulge chase. ==== +* + 140 CONTINUE +* +* ==== Use U (if accumulated) to update far-from-diagonal +* . entries in H. If required, use U to update Z as +* . well. ==== +* + IF( ACCUM ) THEN + IF( WANTT ) THEN + JTOP = 1 + JBOT = N + ELSE + JTOP = KTOP + JBOT = KBOT + END IF + IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR. + $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN +* +* ==== Updates not exploiting the 2-by-2 block +* . structure of U. K1 and NU keep track of +* . the location and size of U in the special +* . cases of introducing bulges and chasing +* . bulges off the bottom. In these special +* . cases and in case the number of shifts +* . is NS = 2, there is no 2-by-2 block +* . structure to exploit. ==== +* + K1 = MAX( 1, KTOP-INCOL ) + NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1 +* +* ==== Horizontal Multiply ==== +* + DO 150 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH + JLEN = MIN( NH, JBOT-JCOL+1 ) + CALL ZGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), + $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, + $ LDWH ) + CALL ZLACPY( 'ALL', NU, JLEN, WH, LDWH, + $ H( INCOL+K1, JCOL ), LDH ) + 150 CONTINUE +* +* ==== Vertical multiply ==== +* + DO 160 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV + JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW ) + CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, + $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), + $ LDU, ZERO, WV, LDWV ) + CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV, + $ H( JROW, INCOL+K1 ), LDH ) + 160 CONTINUE +* +* ==== Z multiply (also vertical) ==== +* + IF( WANTZ ) THEN + DO 170 JROW = ILOZ, IHIZ, NV + JLEN = MIN( NV, IHIZ-JROW+1 ) + CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, + $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), + $ LDU, ZERO, WV, LDWV ) + CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV, + $ Z( JROW, INCOL+K1 ), LDZ ) + 170 CONTINUE + END IF + ELSE +* +* ==== Updates exploiting U's 2-by-2 block structure. +* . (I2, I4, J2, J4 are the last rows and columns +* . of the blocks.) ==== +* + I2 = ( KDU+1 ) / 2 + I4 = KDU + J2 = I4 - I2 + J4 = KDU +* +* ==== KZS and KNZ deal with the band of zeros +* . along the diagonal of one of the triangular +* . blocks. ==== +* + KZS = ( J4-J2 ) - ( NS+1 ) + KNZ = NS + 1 +* +* ==== Horizontal multiply ==== +* + DO 180 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH + JLEN = MIN( NH, JBOT-JCOL+1 ) +* +* ==== Copy bottom of H to top+KZS of scratch ==== +* (The first KZS rows get multiplied by zero.) ==== +* + CALL ZLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), + $ LDH, WH( KZS+1, 1 ), LDWH ) +* +* ==== Multiply by U21**H ==== +* + CALL ZLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH ) + CALL ZTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, + $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), + $ LDWH ) +* +* ==== Multiply top of H by U11**H ==== +* + CALL ZGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, + $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) +* +* ==== Copy top of H to bottom of WH ==== +* + CALL ZLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, + $ WH( I2+1, 1 ), LDWH ) +* +* ==== Multiply by U21**H ==== +* + CALL ZTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, + $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH ) +* +* ==== Multiply by U22 ==== +* + CALL ZGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE, + $ U( J2+1, I2+1 ), LDU, + $ H( INCOL+1+J2, JCOL ), LDH, ONE, + $ WH( I2+1, 1 ), LDWH ) +* +* ==== Copy it back ==== +* + CALL ZLACPY( 'ALL', KDU, JLEN, WH, LDWH, + $ H( INCOL+1, JCOL ), LDH ) + 180 CONTINUE +* +* ==== Vertical multiply ==== +* + DO 190 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV + JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW ) +* +* ==== Copy right of H to scratch (the first KZS +* . columns get multiplied by zero) ==== +* + CALL ZLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), + $ LDH, WV( 1, 1+KZS ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV ) + CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, + $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), + $ LDWV ) +* +* ==== Multiply by U11 ==== +* + CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, + $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, + $ LDWV ) +* +* ==== Copy left of H to right of scratch ==== +* + CALL ZLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, + $ WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, + $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U22 ==== +* + CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, + $ H( JROW, INCOL+1+J2 ), LDH, + $ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ), + $ LDWV ) +* +* ==== Copy it back ==== +* + CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, + $ H( JROW, INCOL+1 ), LDH ) + 190 CONTINUE +* +* ==== Multiply Z (also vertical) ==== +* + IF( WANTZ ) THEN + DO 200 JROW = ILOZ, IHIZ, NV + JLEN = MIN( NV, IHIZ-JROW+1 ) +* +* ==== Copy right of Z to left of scratch (first +* . KZS columns get multiplied by zero) ==== +* + CALL ZLACPY( 'ALL', JLEN, KNZ, + $ Z( JROW, INCOL+1+J2 ), LDZ, + $ WV( 1, 1+KZS ), LDWV ) +* +* ==== Multiply by U12 ==== +* + CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, + $ LDWV ) + CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, + $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), + $ LDWV ) +* +* ==== Multiply by U11 ==== +* + CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, + $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, + $ WV, LDWV ) +* +* ==== Copy left of Z to right of scratch ==== +* + CALL ZLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), + $ LDZ, WV( 1, 1+I2 ), LDWV ) +* +* ==== Multiply by U21 ==== +* + CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, + $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), + $ LDWV ) +* +* ==== Multiply by U22 ==== +* + CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, + $ Z( JROW, INCOL+1+J2 ), LDZ, + $ U( J2+1, I2+1 ), LDU, ONE, + $ WV( 1, 1+I2 ), LDWV ) +* +* ==== Copy the result back to Z ==== +* + CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, + $ Z( JROW, INCOL+1 ), LDZ ) + 200 CONTINUE + END IF + END IF + END IF + 210 CONTINUE +* +* ==== End of ZLAQR5 ==== +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlaqr5} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlarfb LAPACK} +%\pagehead{zlarfb}{zlarfb} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlarfb.input} +)set break resume +)sys rm -f zlarfb.output +)spool zlarfb.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlarfb.help} +==================================================================== +zlarfb examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, + T, LDT, C, LDC, WORK, LDWORK ) + + .. Scalar Arguments .. + CHARACTER DIRECT, SIDE, STOREV, TRANS + INTEGER K, LDC, LDT, LDV, LDWORK, M, N + .. + .. Array Arguments .. + COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), + $ WORK( LDWORK, * ) + .. + + + Purpose: + ============= + + ZLARFB applies a complex block reflector H or its transpose H**H to a + complex M-by-N matrix C, from either the left or the right. + + + Arguments: + ========== + + [in] SIDE + + SIDE is CHARACTER*1 + = 'L': apply H or H**H from the Left + = 'R': apply H or H**H from the Right + + [in] TRANS + + TRANS is CHARACTER*1 + = 'N': apply H (No transpose) + = 'C': apply H**H (Conjugate transpose) + + [in] DIRECT + + DIRECT is CHARACTER*1 + Indicates how H is formed from a product of elementary + reflectors + = 'F': H = H(1) H(2) . . . H(k) (Forward) + = 'B': H = H(k) . . . H(2) H(1) (Backward) + + [in] STOREV + + STOREV is CHARACTER*1 + Indicates how the vectors which define the elementary + reflectors are stored: + = 'C': Columnwise + = 'R': Rowwise + + [in] M + + M is INTEGER + The number of rows of the matrix C. + + [in] N + + N is INTEGER + The number of columns of the matrix C. + + [in] K + + K is INTEGER + The order of the matrix T (= the number of elementary + reflectors whose product defines the block reflector). + + [in] V + + V is COMPLEX*16 array, dimension + (LDV,K) if STOREV = 'C' + (LDV,M) if STOREV = 'R' and SIDE = 'L' + (LDV,N) if STOREV = 'R' and SIDE = 'R' + See Further Details. + + [in] LDV + + LDV is INTEGER + The leading dimension of the array V. + If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); + if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); + if STOREV = 'R', LDV >= K. + + [in] T + + T is COMPLEX*16 array, dimension (LDT,K) + The triangular K-by-K matrix T in the representation of the + block reflector. + + [in] LDT + + LDT is INTEGER + The leading dimension of the array T. LDT >= K. + + [in,out] C + + C is COMPLEX*16 array, dimension (LDC,N) + On entry, the M-by-N matrix C. + On exit, C is overwritten by H*C or H**H*C or C*H or C*H**H. + + [in] LDC + + LDC is INTEGER + The leading dimension of the array C. LDC >= max(1,M). + + [out] WORK + + WORK is COMPLEX*16 array, dimension (LDWORK,K) + + [in] LDWORK + + LDWORK is INTEGER + The leading dimension of the array WORK. + If SIDE = 'L', LDWORK >= max(1,N); + if SIDE = 'R', LDWORK >= max(1,M). + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + + 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': + + V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) + ( v1 1 ) ( 1 v2 v2 v2 ) + ( v1 v2 1 ) ( 1 v3 v3 ) + ( v1 v2 v3 ) + ( v1 v2 v3 ) + + DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': + + V = ( v1 v2 v3 ) V = ( v1 v1 1 ) + ( v1 v2 v3 ) ( v2 v2 v2 1 ) + ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) + ( 1 v3 ) + ( 1 ) + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, + $ T, LDT, C, LDC, WORK, LDWORK ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, SIDE, STOREV, TRANS + INTEGER K, LDC, LDT, LDV, LDWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), + $ WORK( LDWORK, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + CHARACTER TRANST + INTEGER I, J, LASTV, LASTC +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAZLR, ILAZLC + EXTERNAL LSAME, ILAZLR, ILAZLC +* .. +* .. External Subroutines .. + EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( M.LE.0 .OR. N.LE.0 ) + $ RETURN +* + IF( LSAME( TRANS, 'N' ) ) THEN + TRANST = 'C' + ELSE + TRANST = 'N' + END IF +* + IF( LSAME( STOREV, 'C' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 ) (first K rows) +* ( V2 ) +* where V1 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**H * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILAZLR( M, K, V, LDV ) ) + LASTC = ILAZLC( LASTV, N, C, LDC ) +* +* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) +* +* W := C1**H +* + DO 10 J = 1, K + CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) + 10 CONTINUE +* +* W := W * V1 +* + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2**H *V2 +* + CALL ZGEMM( 'Conjugate transpose', 'No transpose', + $ LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC, + $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T**H or W * T +* + CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W**H +* + IF( M.GT.K ) THEN +* +* C2 := C2 - V2 * W**H +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ LASTV-K, LASTC, K, + $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, + $ ONE, C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1**H +* + CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W**H +* + DO 30 J = 1, K + DO 20 I = 1, LASTC + C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**H where C = ( C1 C2 ) +* + LASTV = MAX( K, ILAZLR( N, K, V, LDV ) ) + LASTC = ILAZLR( M, LASTV, C, LDC ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C1 +* + DO 40 J = 1, K + CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + 40 CONTINUE +* +* W := W * V1 +* + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2 * V2 +* + CALL ZGEMM( 'No transpose', 'No transpose', + $ LASTC, K, LASTV-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**H +* + CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V**H +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - W * V2**H +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ LASTC, LASTV-K, K, + $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, + $ ONE, C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1**H +* + CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 60 J = 1, K + DO 50 I = 1, LASTC + C( I, J ) = C( I, J ) - WORK( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF +* + ELSE +* +* Let V = ( V1 ) +* ( V2 ) (last K rows) +* where V2 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**H * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILAZLR( M, K, V, LDV ) ) + LASTC = ILAZLC( LASTV, N, C, LDC ) +* +* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) +* +* W := C2**H +* + DO 70 J = 1, K + CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, + $ WORK( 1, J ), 1 ) + CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) + 70 CONTINUE +* +* W := W * V2 +* + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1**H*V1 +* + CALL ZGEMM( 'Conjugate transpose', 'No transpose', + $ LASTC, K, LASTV-K, + $ ONE, C, LDC, V, LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**H or W * T +* + CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W**H +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - V1 * W**H +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ LASTV-K, LASTC, K, + $ -ONE, V, LDV, WORK, LDWORK, + $ ONE, C, LDC ) + END IF +* +* W := W * V2**H +* + CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', + $ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W**H +* + DO 90 J = 1, K + DO 80 I = 1, LASTC + C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - + $ DCONJG( WORK( I, J ) ) + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**H where C = ( C1 C2 ) +* + LASTV = MAX( K, ILAZLR( N, K, V, LDV ) ) + LASTC = ILAZLR( M, LASTV, C, LDC ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C2 +* + DO 100 J = 1, K + CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1, + $ WORK( 1, J ), 1 ) + 100 CONTINUE +* +* W := W * V2 +* + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1 * V1 +* + CALL ZGEMM( 'No transpose', 'No transpose', + $ LASTC, K, LASTV-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**H +* + CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V**H +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - W * V1**H +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, + $ ONE, C, LDC ) + END IF +* +* W := W * V2**H +* + CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', + $ 'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W +* + DO 120 J = 1, K + DO 110 I = 1, LASTC + C( I, LASTV-K+J ) = C( I, LASTV-K+J ) + $ - WORK( I, J ) + 110 CONTINUE + 120 CONTINUE + END IF + END IF +* + ELSE IF( LSAME( STOREV, 'R' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 V2 ) (V1: first K columns) +* where V1 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**H * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILAZLC( K, M, V, LDV ) ) + LASTC = ILAZLC( LASTV, N, C, LDC ) +* +* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) +* +* W := C1**H +* + DO 130 J = 1, K + CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) + 130 CONTINUE +* +* W := W * V1**H +* + CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', + $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2**H*V2**H +* + CALL ZGEMM( 'Conjugate transpose', + $ 'Conjugate transpose', LASTC, K, LASTV-K, + $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T**H or W * T +* + CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V**H * W**H +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - V2**H * W**H +* + CALL ZGEMM( 'Conjugate transpose', + $ 'Conjugate transpose', LASTV-K, LASTC, K, + $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, + $ ONE, C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W**H +* + DO 150 J = 1, K + DO 140 I = 1, LASTC + C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) + 140 CONTINUE + 150 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**H where C = ( C1 C2 ) +* + LASTV = MAX( K, ILAZLC( K, N, V, LDV ) ) + LASTC = ILAZLR( M, LASTV, C, LDC ) +* +* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) +* +* W := C1 +* + DO 160 J = 1, K + CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + 160 CONTINUE +* +* W := W * V1**H +* + CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', + $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C2 * V2**H +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC, + $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T**H +* + CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( LASTV.GT.K ) THEN +* +* C2 := C2 - W * V2 +* + CALL ZGEMM( 'No transpose', 'No transpose', + $ LASTC, LASTV-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, + $ ONE, C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', + $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 180 J = 1, K + DO 170 I = 1, LASTC + C( I, J ) = C( I, J ) - WORK( I, J ) + 170 CONTINUE + 180 CONTINUE +* + END IF +* + ELSE +* +* Let V = ( V1 V2 ) (V2: last K columns) +* where V2 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H**H * C where C = ( C1 ) +* ( C2 ) +* + LASTV = MAX( K, ILAZLC( K, M, V, LDV ) ) + LASTC = ILAZLC( LASTV, N, C, LDC ) +* +* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) +* +* W := C2**H +* + DO 190 J = 1, K + CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC, + $ WORK( 1, J ), 1 ) + CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) + 190 CONTINUE +* +* W := W * V2**H +* + CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1**H * V1**H +* + CALL ZGEMM( 'Conjugate transpose', + $ 'Conjugate transpose', LASTC, K, LASTV-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T**H or W * T +* + CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V**H * W**H +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - V1**H * W**H +* + CALL ZGEMM( 'Conjugate transpose', + $ 'Conjugate transpose', LASTV-K, LASTC, K, + $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) +* +* C2 := C2 - W**H +* + DO 210 J = 1, K + DO 200 I = 1, LASTC + C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - + $ DCONJG( WORK( I, J ) ) + 200 CONTINUE + 210 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H**H where C = ( C1 C2 ) +* + LASTV = MAX( K, ILAZLC( K, N, V, LDV ) ) + LASTC = ILAZLR( M, LASTV, C, LDC ) +* +* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) +* +* W := C2 +* + DO 220 J = 1, K + CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1, + $ WORK( 1, J ), 1 ) + 220 CONTINUE +* +* W := W * V2**H +* + CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', + $ 'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) + IF( LASTV.GT.K ) THEN +* +* W := W + C1 * V1**H +* + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, ONE, + $ WORK, LDWORK ) + END IF +* +* W := W * T or W * T**H +* + CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', + $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( LASTV.GT.K ) THEN +* +* C1 := C1 - W * V1 +* + CALL ZGEMM( 'No transpose', 'No transpose', + $ LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV, + $ ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', + $ LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV, + $ WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 240 J = 1, K + DO 230 I = 1, LASTC + C( I, LASTV-K+J ) = C( I, LASTV-K+J ) + $ - WORK( I, J ) + 230 CONTINUE + 240 CONTINUE +* + END IF +* + END IF + END IF +* + RETURN +* +* End of ZLARFB +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlarfb} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlarf LAPACK} +%\pagehead{zlarf}{zlarf} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlarf.input} +)set break resume +)sys rm -f zlarf.output +)spool zlarf.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlarf.help} +==================================================================== +zlarf examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) + + .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + COMPLEX*16 TAU + .. + .. Array Arguments .. + COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) + .. + + + Purpose: + ============= + + ZLARF applies a complex elementary reflector H to a complex M-by-N + matrix C, from either the left or the right. H is represented in the + form + + H = I - tau * v * v**H + + where tau is a complex scalar and v is a complex vector. + + If tau = 0, then H is taken to be the unit matrix. + + To apply H**H, supply conjg(tau) instead + tau. + + Arguments: + ========== + + [in] SIDE + + SIDE is CHARACTER*1 + = 'L': form H * C + = 'R': form C * H + + [in] M + + M is INTEGER + The number of rows of the matrix C. + + [in] N + + N is INTEGER + The number of columns of the matrix C. + + [in] V + + V is COMPLEX*16 array, dimension + (1 + (M-1)*abs(INCV)) if SIDE = 'L' + or (1 + (N-1)*abs(INCV)) if SIDE = 'R' + The vector v in the representation of H. V is not used if + TAU = 0. + + [in] INCV + + INCV is INTEGER + The increment between elements of v. INCV <> 0. + + [in] TAU + + TAU is COMPLEX*16 + The value tau in the representation of H. + + [in,out] C + + C is COMPLEX*16 array, dimension (LDC,N) + On entry, the M-by-N matrix C. + On exit, C is overwritten by the matrix H * C if SIDE = 'L', + or C * H if SIDE = 'R'. + + [in] LDC + + LDC is INTEGER + The leading dimension of the array C. LDC >= max(1,M). + + [out] WORK + + WORK is COMPLEX*16 array, dimension + (N) if SIDE = 'L' + or (M) if SIDE = 'R' + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + COMPLEX*16 TAU +* .. +* .. Array Arguments .. + COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, LASTV, LASTC +* .. +* .. External Subroutines .. + EXTERNAL ZGEMV, ZGERC +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAZLR, ILAZLC + EXTERNAL LSAME, ILAZLR, ILAZLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + LASTV = 0 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +* Set up variables for scanning V. LASTV begins pointing to the end +* of V. + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + IF( INCV.GT.0 ) THEN + I = 1 + (LASTV-1) * INCV + ELSE + I = 1 + END IF +* Look for the last non-zero row in V. + DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) + LASTV = LASTV - 1 + I = I - INCV + END DO + IF( APPLYLEFT ) THEN +* Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILAZLC(LASTV, N, C, LDC) + ELSE +* Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILAZLR(M, LASTV, C, LDC) + END IF + END IF +* Note that lastc.eq.0 renders the BLAS operations null; no special +* case is needed at this level. + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1) +* + CALL ZGEMV( 'Conjugate transpose', LASTV, LASTC, ONE, + $ C, LDC, V, INCV, ZERO, WORK, 1 ) +* +* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H +* + CALL ZGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.GT.0 ) THEN +* +* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) +* + CALL ZGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, + $ V, INCV, ZERO, WORK, 1 ) +* +* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H +* + CALL ZGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) + END IF + END IF + RETURN +* +* End of ZLARF +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlarf} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlarfg LAPACK} +%\pagehead{zlarfg}{zlarfg} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlarfg.input} +)set break resume +)sys rm -f zlarfg.output +)spool zlarfg.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlarfg.help} +==================================================================== +zlarfg examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) + + .. Scalar Arguments .. + INTEGER INCX, N + COMPLEX*16 ALPHA, TAU + .. + .. Array Arguments .. + COMPLEX*16 X( * ) + .. + + + Purpose: + ============= + + ZLARFG generates a complex elementary reflector H of order n, such + that + + H**H * ( alpha ) = ( beta ), H**H * H = I. + ( x ) ( 0 ) + + where alpha and beta are scalars, with beta real, and x is an + (n-1)-element complex vector. H is represented in the form + + H = I - tau * ( 1 ) * ( 1 v**H ) , + ( v ) + + where tau is a complex scalar and v is a complex (n-1)-element + vector. Note that H is not hermitian. + + If the elements of x are all zero and alpha is real, then tau = 0 + and H is taken to be the unit matrix. + + Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . + + Arguments: + ========== + + [in] N + + N is INTEGER + The order of the elementary reflector. + + [in,out] ALPHA + + ALPHA is COMPLEX*16 + On entry, the value alpha. + On exit, it is overwritten with the value beta. + + [in,out] X + + X is COMPLEX*16 array, dimension + (1+(N-2)*abs(INCX)) + On entry, the vector x. + On exit, it is overwritten with the vector v. + + [in] INCX + + INCX is INTEGER + The increment between elements of X. INCX > 0. + + [out] TAU + + TAU is COMPLEX*16 + The value tau. + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER INCX, N + COMPLEX*16 ALPHA, TAU +* .. +* .. Array Arguments .. + COMPLEX*16 X( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER J, KNT + DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2 + COMPLEX*16 ZLADIV + EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN +* .. +* .. External Subroutines .. + EXTERNAL ZDSCAL, ZSCAL +* .. +* .. Executable Statements .. +* + IF( N.LE.0 ) THEN + TAU = ZERO + RETURN + END IF +* + XNORM = DZNRM2( N-1, X, INCX ) + ALPHR = DBLE( ALPHA ) + ALPHI = DIMAG( ALPHA ) +* + IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN +* +* H = I +* + TAU = ZERO + ELSE +* +* general case +* + BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) + SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) + RSAFMN = ONE / SAFMIN +* + KNT = 0 + IF( ABS( BETA ).LT.SAFMIN ) THEN +* +* XNORM, BETA may be inaccurate; scale X and recompute them +* + 10 CONTINUE + KNT = KNT + 1 + CALL ZDSCAL( N-1, RSAFMN, X, INCX ) + BETA = BETA*RSAFMN + ALPHI = ALPHI*RSAFMN + ALPHR = ALPHR*RSAFMN + IF( ABS( BETA ).LT.SAFMIN ) + $ GO TO 10 +* +* New BETA is at most 1, at least SAFMIN +* + XNORM = DZNRM2( N-1, X, INCX ) + ALPHA = DCMPLX( ALPHR, ALPHI ) + BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) + END IF + TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) + ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) + CALL ZSCAL( N-1, ALPHA, X, INCX ) +* +* If ALPHA is subnormal, it may lose relative accuracy +* + DO 20 J = 1, KNT + BETA = BETA*SAFMIN + 20 CONTINUE + ALPHA = BETA + END IF +* + RETURN +* +* End of ZLARFG +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlarfg} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlarft LAPACK} +%\pagehead{zlarft}{zlarft} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlarft.input} +)set break resume +)sys rm -f zlarft.output +)spool zlarft.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlarft.help} +==================================================================== +zlarft examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) + + .. Scalar Arguments .. + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N + .. + .. Array Arguments .. + COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) + .. + + + Purpose: + ============= + + ZLARFT forms the triangular factor T of a complex block reflector H + of order n, which is defined as a product of k elementary reflectors. + + If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; + + If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. + + If STOREV = 'C', the vector which defines the elementary reflector + H(i) is stored in the i-th column of the array V, and + + H = I - V * T * V**H + + If STOREV = 'R', the vector which defines the elementary reflector + H(i) is stored in the i-th row of the array V, and + + H = I - V**H * T * V + + Arguments: + ========== + + [in] DIRECT + + DIRECT is CHARACTER*1 + Specifies the order in which the elementary reflectors are + multiplied to form the block reflector: + = 'F': H = H(1) H(2) . . . H(k) (Forward) + = 'B': H = H(k) . . . H(2) H(1) (Backward) + + [in] STOREV + + STOREV is CHARACTER*1 + Specifies how the vectors which define the elementary + reflectors are stored (see also Further Details): + = 'C': columnwise + = 'R': rowwise + + [in] N + + N is INTEGER + The order of the block reflector H. N >= 0. + + [in] K + + K is INTEGER + The order of the triangular factor T (= the number of + elementary reflectors). K >= 1. + + [in,out] V + + V is COMPLEX*16 array, dimension + (LDV,K) if STOREV = 'C' + (LDV,N) if STOREV = 'R' + The matrix V. See further details. + + [in] LDV + + LDV is INTEGER + The leading dimension of the array V. + If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. + + [in] TAU + + TAU is COMPLEX*16 array, dimension (K) + TAU(i) must contain the scalar factor of the elementary + reflector H(i). + + [out] T + + T is COMPLEX*16 array, dimension (LDT,K) + The k by k triangular factor T of the block reflector. + If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is + lower triangular. The rest of the array is not used. + + [in] LDT + + LDT is INTEGER + The leading dimension of the array T. LDT >= K. + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + + 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': + + V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) + ( v1 1 ) ( 1 v2 v2 v2 ) + ( v1 v2 1 ) ( 1 v3 v3 ) + ( v1 v2 v3 ) + ( v1 v2 v3 ) + + DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': + + V = ( v1 v2 v3 ) V = ( v1 v1 1 ) + ( v1 v2 v3 ) ( v2 v2 v2 1 ) + ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) + ( 1 v3 ) + ( 1 ) + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. + COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, J, PREVLASTV, LASTV + COMPLEX*16 VII +* .. +* .. External Subroutines .. + EXTERNAL ZGEMV, ZLACGV, ZTRMV +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( LSAME( DIRECT, 'F' ) ) THEN + PREVLASTV = N + DO 20 I = 1, K + PREVLASTV = MAX( PREVLASTV, I ) + 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 +! Skip any trailing zeros. + DO LASTV = N, I+1, -1 + IF( V( LASTV, I ).NE.ZERO ) EXIT + END DO + J = MIN( LASTV, PREVLASTV ) +* +* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i) +* + CALL ZGEMV( 'Conjugate transpose', J-I+1, I-1, + $ -TAU( I ), V( I, 1 ), LDV, V( I, I ), 1, + $ ZERO, T( 1, I ), 1 ) + ELSE +! Skip any trailing zeros. + DO LASTV = N, I+1, -1 + IF( V( I, LASTV ).NE.ZERO ) EXIT + END DO + J = MIN( LASTV, PREVLASTV ) +* +* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H +* + IF( I.LT.J ) + $ CALL ZLACGV( J-I, V( I, I+1 ), LDV ) + CALL ZGEMV( 'No transpose', I-1, J-I+1, -TAU( I ), + $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, + $ T( 1, I ), 1 ) + IF( I.LT.J ) + $ CALL ZLACGV( J-I, V( I, I+1 ), LDV ) + END IF + V( I, I ) = VII +* +* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) +* + CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, + $ LDT, T( 1, I ), 1 ) + T( I, I ) = TAU( I ) + IF( I.GT.1 ) THEN + PREVLASTV = MAX( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF + END IF + 20 CONTINUE + ELSE + PREVLASTV = 1 + 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 +! Skip any leading zeros. + DO LASTV = 1, I-1 + IF( V( LASTV, I ).NE.ZERO ) EXIT + END DO + J = MAX( LASTV, PREVLASTV ) +* +* T(i+1:k,i) := +* - tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i) +* + CALL ZGEMV( 'Conjugate transpose', N-K+I-J+1, K-I, + $ -TAU( I ), V( J, I+1 ), LDV, V( J, 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 +! Skip any leading zeros. + DO LASTV = 1, I-1 + IF( V( I, LASTV ).NE.ZERO ) EXIT + END DO + J = MAX( LASTV, PREVLASTV ) +* +* T(i+1:k,i) := +* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H +* + CALL ZLACGV( N-K+I-1-J+1, V( I, J ), LDV ) + CALL ZGEMV( 'No transpose', K-I, N-K+I-J+1, + $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, + $ ZERO, T( I+1, I ), 1 ) + CALL ZLACGV( N-K+I-1-J+1, V( I, J ), LDV ) + 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 ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, + $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) + IF( I.GT.1 ) THEN + PREVLASTV = MIN( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF + END IF + T( I, I ) = TAU( I ) + END IF + 40 CONTINUE + END IF + RETURN +* +* End of ZLARFT +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlarft} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlartg LAPACK} +%\pagehead{zlartg}{zlartg} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlartg.input} +)set break resume +)sys rm -f zlartg.output +)spool zlartg.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlartg.help} +==================================================================== +zlartg examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZLARTG( F, G, CS, SN, R ) + + .. Scalar Arguments .. + DOUBLE PRECISION CS + COMPLEX*16 F, G, R, SN + .. + + + Purpose: + ============= + + ZLARTG generates a plane rotation so that + + [ CS SN ] [ F ] [ R ] + [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1. + [ -SN CS ] [ G ] [ 0 ] + + This is a faster version of the BLAS1 routine ZROTG, except for + the following differences: + F and G are unchanged on return. + If G=0, then CS=1 and SN=0. + If F=0, then CS=0 and SN is chosen so that R is real. + + Arguments: + ========== + + [in] F + + F is COMPLEX*16 + The first component of vector to be rotated. + + [in] G + + G is COMPLEX*16 + The second component of vector to be rotated. + + [out] CS + + CS is DOUBLE PRECISION + The cosine of the rotation. + + [out] SN + + SN is COMPLEX*16 + The sine of the rotation. + + [out] R + + R is COMPLEX*16 + The nonzero component of the rotated vector. + + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + + Further Details: + ===================== + + 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel + + This version has a few statements commented out for thread safety + (machine parameters are computed on each entry). 10 feb 03, SJH. + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZLARTG( F, G, CS, SN, R ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + DOUBLE PRECISION CS + COMPLEX*16 F, G, R, SN +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION TWO, ONE, ZERO + PARAMETER ( TWO = 2.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. +* LOGICAL FIRST + INTEGER COUNT, I + DOUBLE PRECISION D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN, + $ SAFMN2, SAFMX2, SCALE + COMPLEX*16 FF, FS, GS +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG, + $ MAX, SQRT +* .. +* .. Statement Functions .. + DOUBLE PRECISION ABS1, ABSSQ +* .. +* .. Save statement .. +* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 +* .. +* .. Data statements .. +* DATA FIRST / .TRUE. / +* .. +* .. Statement Function definitions .. + ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) ) + ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2 +* .. +* .. Executable Statements .. +* +* IF( FIRST ) THEN + SAFMIN = DLAMCH( 'S' ) + EPS = DLAMCH( 'E' ) + SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / + $ LOG( DLAMCH( 'B' ) ) / TWO ) + SAFMX2 = ONE / SAFMN2 +* FIRST = .FALSE. +* END IF + SCALE = MAX( ABS1( F ), ABS1( G ) ) + FS = F + GS = G + COUNT = 0 + IF( SCALE.GE.SAFMX2 ) THEN + 10 CONTINUE + COUNT = COUNT + 1 + FS = FS*SAFMN2 + GS = GS*SAFMN2 + SCALE = SCALE*SAFMN2 + IF( SCALE.GE.SAFMX2 ) + $ GO TO 10 + ELSE IF( SCALE.LE.SAFMN2 ) THEN + IF( G.EQ.CZERO ) THEN + CS = ONE + SN = CZERO + R = F + RETURN + END IF + 20 CONTINUE + COUNT = COUNT - 1 + FS = FS*SAFMX2 + GS = GS*SAFMX2 + SCALE = SCALE*SAFMX2 + IF( SCALE.LE.SAFMN2 ) + $ GO TO 20 + END IF + F2 = ABSSQ( FS ) + G2 = ABSSQ( GS ) + IF( F2.LE.MAX( G2, ONE )*SAFMIN ) THEN +* +* This is a rare case: F is very small. +* + IF( F.EQ.CZERO ) THEN + CS = ZERO + R = DLAPY2( DBLE( G ), DIMAG( G ) ) +* Do complex/real division explicitly with two real divisions + D = DLAPY2( DBLE( GS ), DIMAG( GS ) ) + SN = DCMPLX( DBLE( GS ) / D, -DIMAG( GS ) / D ) + RETURN + END IF + F2S = DLAPY2( DBLE( FS ), DIMAG( FS ) ) +* G2 and G2S are accurate +* G2 is at least SAFMIN, and G2S is at least SAFMN2 + G2S = SQRT( G2 ) +* Error in CS from underflow in F2S is at most +* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS +* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, +* and so CS .lt. sqrt(SAFMIN) +* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN +* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) +* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S + CS = F2S / G2S +* Make sure abs(FF) = 1 +* Do complex/real division explicitly with 2 real divisions + IF( ABS1( F ).GT.ONE ) THEN + D = DLAPY2( DBLE( F ), DIMAG( F ) ) + FF = DCMPLX( DBLE( F ) / D, DIMAG( F ) / D ) + ELSE + DR = SAFMX2*DBLE( F ) + DI = SAFMX2*DIMAG( F ) + D = DLAPY2( DR, DI ) + FF = DCMPLX( DR / D, DI / D ) + END IF + SN = FF*DCMPLX( DBLE( GS ) / G2S, -DIMAG( GS ) / G2S ) + R = CS*F + SN*G + ELSE +* +* This is the most common case. +* Neither F2 nor F2/G2 are less than SAFMIN +* F2S cannot overflow, and it is accurate +* + F2S = SQRT( ONE+G2 / F2 ) +* Do the F2S(real)*FS(complex) multiply with two real multiplies + R = DCMPLX( F2S*DBLE( FS ), F2S*DIMAG( FS ) ) + CS = ONE / F2S + D = F2 + G2 +* Do complex/real division explicitly with two real divisions + SN = DCMPLX( DBLE( R ) / D, DIMAG( R ) / D ) + SN = SN*DCONJG( GS ) + IF( COUNT.NE.0 ) THEN + IF( COUNT.GT.0 ) THEN + DO 30 I = 1, COUNT + R = R*SAFMX2 + 30 CONTINUE + ELSE + DO 40 I = 1, -COUNT + R = R*SAFMN2 + 40 CONTINUE + END IF + END IF + END IF + RETURN +* +* End of ZLARTG +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlartg} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlascl LAPACK} +%\pagehead{zlascl}{zlascl} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlascl.input} +)set break resume +)sys rm -f zlascl.output +)spool zlascl.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlascl.help} +==================================================================== +zlascl examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) + + .. Scalar Arguments .. + CHARACTER TYPE + INTEGER INFO, KL, KU, LDA, M, N + DOUBLE PRECISION CFROM, CTO + .. + .. Array Arguments .. + COMPLEX*16 A( LDA, * ) + .. + + + Purpose: + ============= + + ZLASCL multiplies the M by N complex matrix A by the real scalar + CTO/CFROM. This is done without over/underflow as long as the final + result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that + A may be full, upper triangular, lower triangular, upper Hessenberg, + or banded. + + Arguments: + ========== + + [in] TYPE + + TYPE is CHARACTER*1 + TYPE indices the storage type of the input matrix. + = 'G': A is a full matrix. + = 'L': A is a lower triangular matrix. + = 'U': A is an upper triangular matrix. + = 'H': A is an upper Hessenberg matrix. + = 'B': A is a symmetric band matrix with lower bandwidth KL + and upper bandwidth KU and with the only the lower + half stored. + = 'Q': A is a symmetric band matrix with lower bandwidth KL + and upper bandwidth KU and with the only the upper + half stored. + = 'Z': A is a band matrix with lower bandwidth KL and upper + bandwidth KU. See ZGBTRF for storage details. + + [in] KL + + KL is INTEGER + The lower bandwidth of A. Referenced only if TYPE = 'B', + 'Q' or 'Z'. + + [in] KU + + KU is INTEGER + The upper bandwidth of A. Referenced only if TYPE = 'B', + 'Q' or 'Z'. + + [in] CFROM + + CFROM is DOUBLE PRECISION + + [in] CTO + + CTO is DOUBLE PRECISION + + The matrix A is multiplied by CTO/CFROM. A(I,J) is computed + without over/underflow if the final result CTO*A(I,J)/CFROM + can be represented without over/underflow. CFROM must be + nonzero. + + [in] M + + M is INTEGER + The number of rows of the matrix A. M >= 0. + + [in] N + + N is INTEGER + The number of columns of the matrix A. N >= 0. + + [in,out] A + + A is COMPLEX*16 array, dimension (LDA,N) + The matrix to be multiplied by CTO/CFROM. See TYPE for the + storage type. + + [in] LDA + + LDA is INTEGER + The leading dimension of the array A. LDA >= max(1,M). + + [out] INFO + + INFO is INTEGER + 0 - successful exit + <0 - if INFO = -i, the i-th argument had an illegal value. + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER TYPE + INTEGER INFO, KL, KU, LDA, M, N + DOUBLE PRECISION CFROM, CTO +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER I, ITYPE, J, K1, K2, K3, K4 + DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME, DISNAN + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH, DISNAN +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 +* + IF( LSAME( TYPE, 'G' ) ) THEN + ITYPE = 0 + ELSE IF( LSAME( TYPE, 'L' ) ) THEN + ITYPE = 1 + ELSE IF( LSAME( TYPE, 'U' ) ) THEN + ITYPE = 2 + ELSE IF( LSAME( TYPE, 'H' ) ) THEN + ITYPE = 3 + ELSE IF( LSAME( TYPE, 'B' ) ) THEN + ITYPE = 4 + ELSE IF( LSAME( TYPE, 'Q' ) ) THEN + ITYPE = 5 + ELSE IF( LSAME( TYPE, 'Z' ) ) THEN + ITYPE = 6 + ELSE + ITYPE = -1 + END IF +* + IF( ITYPE.EQ.-1 ) THEN + INFO = -1 + ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN + INFO = -4 + ELSE IF( DISNAN(CTO) ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. + $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN + INFO = -7 + ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( ITYPE.GE.4 ) THEN + IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN + INFO = -2 + ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. + $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) + $ THEN + INFO = -3 + ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. + $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. + $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN + INFO = -9 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLASCL', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +* +* Get machine parameters +* + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM +* + CFROMC = CFROM + CTOC = CTO +* + 10 CONTINUE + CFROM1 = CFROMC*SMLNUM + IF( CFROM1.EQ.CFROMC ) THEN +! CFROMC is an inf. Multiply by a correctly signed zero for +! finite CTOC, or a NaN if CTOC is infinite. + MUL = CTOC / CFROMC + DONE = .TRUE. + CTO1 = CTOC + ELSE + CTO1 = CTOC / BIGNUM + IF( CTO1.EQ.CTOC ) THEN +! CTOC is either 0 or an inf. In both cases, CTOC itself +! serves as the correct multiplication factor. + MUL = CTOC + DONE = .TRUE. + CFROMC = ONE + ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN + MUL = SMLNUM + DONE = .FALSE. + CFROMC = CFROM1 + ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN + MUL = BIGNUM + DONE = .FALSE. + CTOC = CTO1 + ELSE + MUL = CTOC / CFROMC + DONE = .TRUE. + END IF + END IF +* + IF( ITYPE.EQ.0 ) THEN +* +* Full matrix +* + DO 30 J = 1, N + DO 20 I = 1, M + A( I, J ) = A( I, J )*MUL + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( ITYPE.EQ.1 ) THEN +* +* Lower triangular matrix +* + DO 50 J = 1, N + DO 40 I = J, M + A( I, J ) = A( I, J )*MUL + 40 CONTINUE + 50 CONTINUE +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Upper triangular matrix +* + DO 70 J = 1, N + DO 60 I = 1, MIN( J, M ) + A( I, J ) = A( I, J )*MUL + 60 CONTINUE + 70 CONTINUE +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* Upper Hessenberg matrix +* + DO 90 J = 1, N + DO 80 I = 1, MIN( J+1, M ) + A( I, J ) = A( I, J )*MUL + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Lower half of a symmetric band matrix +* + K3 = KL + 1 + K4 = N + 1 + DO 110 J = 1, N + DO 100 I = 1, MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 100 CONTINUE + 110 CONTINUE +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Upper half of a symmetric band matrix +* + K1 = KU + 2 + K3 = KU + 1 + DO 130 J = 1, N + DO 120 I = MAX( K1-J, 1 ), K3 + A( I, J ) = A( I, J )*MUL + 120 CONTINUE + 130 CONTINUE +* + ELSE IF( ITYPE.EQ.6 ) THEN +* +* Band matrix +* + K1 = KL + KU + 2 + K2 = KL + 1 + K3 = 2*KL + KU + 1 + K4 = KL + KU + 1 + M + DO 150 J = 1, N + DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 140 CONTINUE + 150 CONTINUE +* + END IF +* + IF( .NOT.DONE ) + $ GO TO 10 +* + RETURN +* +* End of ZLASCL +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlascl} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlaset LAPACK} +%\pagehead{zlaset}{zlaset} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlaset.input} +)set break resume +)sys rm -f zlaset.output +)spool zlaset.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlaset.help} +==================================================================== +zlaset examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) + + .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, M, N + COMPLEX*16 ALPHA, BETA + .. + .. Array Arguments .. + COMPLEX*16 A( LDA, * ) + .. + + + Purpose: + ============= + + ZLASET initializes a 2-D array A to BETA on the diagonal and + ALPHA on the offdiagonals. + + Arguments: + ========== + + [in] UPLO + + UPLO is CHARACTER*1 + Specifies the part of the matrix A to be set. + = 'U': Upper triangular part is set. The lower triangle + is unchanged. + = 'L': Lower triangular part is set. The upper triangle + is unchanged. + Otherwise: All of the matrix A is set. + + [in] M + + M is INTEGER + On entry, M specifies the number of rows of A. + + [in] N + + N is INTEGER + On entry, N specifies the number of columns of A. + + [in] ALPHA + + ALPHA is COMPLEX*16 + All the offdiagonal array elements are set to ALPHA. + + [in] BETA + + BETA is COMPLEX*16 + All the diagonal array elements are set to BETA. + + [in,out] A + + A is COMPLEX*16 array, dimension (LDA,N) + On entry, the m by n matrix A. + On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j; + A(i,i) = BETA , 1 <= i <= min(m,n) + + [in] LDA + + LDA is INTEGER + The leading dimension of the array A. LDA >= max(1,M). + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, M, N + COMPLEX*16 ALPHA, BETA +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Set the diagonal to BETA and the strictly upper triangular +* part of the array to ALPHA. +* + DO 20 J = 2, N + DO 10 I = 1, MIN( J-1, M ) + A( I, J ) = ALPHA + 10 CONTINUE + 20 CONTINUE + DO 30 I = 1, MIN( N, M ) + A( I, I ) = BETA + 30 CONTINUE +* + ELSE IF( LSAME( UPLO, 'L' ) ) THEN +* +* Set the diagonal to BETA and the strictly lower triangular +* part of the array to ALPHA. +* + DO 50 J = 1, MIN( M, N ) + DO 40 I = J + 1, M + A( I, J ) = ALPHA + 40 CONTINUE + 50 CONTINUE + DO 60 I = 1, MIN( N, M ) + A( I, I ) = BETA + 60 CONTINUE +* + ELSE +* +* Set the array to BETA on the diagonal and ALPHA on the +* offdiagonal. +* + DO 80 J = 1, N + DO 70 I = 1, M + A( I, J ) = ALPHA + 70 CONTINUE + 80 CONTINUE + DO 90 I = 1, MIN( M, N ) + A( I, I ) = BETA + 90 CONTINUE + END IF +* + RETURN +* +* End of ZLASET +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlaset} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlassq LAPACK} +%\pagehead{zlassq}{zlassq} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlassq.input} +)set break resume +)sys rm -f zlassq.output +)spool zlassq.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlassq.help} +==================================================================== +zlassq examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) + + .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION SCALE, SUMSQ + .. + .. Array Arguments .. + COMPLEX*16 X( * ) + .. + + + Purpose: + ============= + + ZLASSQ returns the values scl and ssq such that + + ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, + + where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is + assumed to be at least unity and the value of ssq will then satisfy + + 1.0 .le. ssq .le. ( sumsq + 2*n ). + + scale is assumed to be non-negative and scl returns the value + + scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), + i + + scale and sumsq must be supplied in SCALE and SUMSQ respectively. + SCALE and SUMSQ are overwritten by scl and ssq respectively. + + The routine makes only one pass through the vector X. + + Arguments: + ========== + + [in] N + + N is INTEGER + The number of elements to be used from the vector X. + + [in] X + + X is COMPLEX*16 array, dimension (N) + The vector x as described above. + x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. + + [in] INCX + + INCX is INTEGER + The increment between successive values of the vector X. + INCX > 0. + + [in,out] SCALE + + SCALE is DOUBLE PRECISION + On entry, the value scale in the equation above. + On exit, SCALE is overwritten with the value scl . + + [in,out] SUMSQ + + SUMSQ is DOUBLE PRECISION + On entry, the value sumsq in the equation above. + On exit, SUMSQ is overwritten with the value ssq . + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION SCALE, SUMSQ +* .. +* .. Array Arguments .. + COMPLEX*16 X( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER IX + DOUBLE PRECISION TEMP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG +* .. +* .. Executable Statements .. +* + IF( N.GT.0 ) THEN + DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX + IF( DBLE( X( IX ) ).NE.ZERO ) THEN + TEMP1 = ABS( DBLE( X( IX ) ) ) + IF( SCALE.LT.TEMP1 ) THEN + SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 + SCALE = TEMP1 + ELSE + SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 + END IF + END IF + IF( DIMAG( X( IX ) ).NE.ZERO ) THEN + TEMP1 = ABS( DIMAG( X( IX ) ) ) + IF( SCALE.LT.TEMP1 ) THEN + SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 + SCALE = TEMP1 + ELSE + SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 + END IF + END IF + 10 CONTINUE + END IF +* + RETURN +* +* End of ZLASSQ +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlassq} +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun zlassq (n x incx scale sumsq) + (declare (type (double-float) sumsq scale) + (type (simple-array (complex double-float) (*)) x) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((x (complex double-float) x-%data% x-%offset%)) + (prog ((temp1 0.0) (ix 0)) + (declare (type (double-float) temp1) (type fixnum ix)) + (cond + ((> n 0) + (f2cl-lib:fdo (ix 1 (f2cl-lib:int-add ix incx)) + ((> ix + (f2cl-lib:int-add 1 + (f2cl-lib:int-mul + (f2cl-lib:int-add n + (f2cl-lib:int-sub 1)) + incx))) + nil) + (tagbody + (cond + ((/= (coerce (realpart (f2cl-lib:fref x (ix) ((1 *)))) 'double-float) zero) + (setf temp1 + (abs + (coerce (realpart + (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%)) 'double-float))) + (cond + ((< scale temp1) + (setf sumsq (+ 1 (* sumsq (expt (/ scale temp1) 2)))) + (setf scale temp1)) + (t + (setf sumsq (+ sumsq (expt (/ temp1 scale) 2))))))) + (cond + ((/= (f2cl-lib:dimag (f2cl-lib:fref x (ix) ((1 *)))) zero) + (setf temp1 + (abs + (f2cl-lib:dimag + (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%)))) + (cond + ((< scale temp1) + (setf sumsq (+ 1 (* sumsq (expt (/ scale temp1) 2)))) + (setf scale temp1)) + (t + (setf sumsq (+ sumsq (expt (/ temp1 scale) 2))))))))))) + (return (values nil nil nil scale sumsq)))))) + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlatrs LAPACK} +%\pagehead{zlatrs}{zlatrs} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zlatrs.input} +)set break resume +)sys rm -f zlatrs.output +)spool zlatrs.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zlatrs.help} +==================================================================== +zlatrs examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, + CNORM, INFO ) + + .. Scalar Arguments .. + CHARACTER DIAG, NORMIN, TRANS, UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION SCALE + .. + .. Array Arguments .. + DOUBLE PRECISION CNORM( * ) + COMPLEX*16 A( LDA, * ), X( * ) + .. + + + Purpose: + ============= + + ZLATRS solves one of the triangular systems + + A * x = s*b, A**T * x = s*b, or A**H * x = s*b, + + with scaling to prevent overflow. Here A is an upper or lower + triangular matrix, A**T denotes the transpose of A, A**H denotes the + conjugate transpose of A, x and b are n-element vectors, and s is a + scaling factor, usually less than or equal to 1, chosen so that the + components of x will be less than the overflow threshold. If the + unscaled problem will not cause overflow, the Level 2 BLAS routine + ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), + then s is set to 0 and a non-trivial solution to A*x = 0 is returned. + + Arguments: + ========== + + [in] UPLO + + UPLO is CHARACTER*1 + Specifies whether the matrix A is upper or lower triangular. + = 'U': Upper triangular + = 'L': Lower triangular + + [in] TRANS + + TRANS is CHARACTER*1 + Specifies the operation applied to A. + = 'N': Solve A * x = s*b (No transpose) + = 'T': Solve A**T * x = s*b (Transpose) + = 'C': Solve A**H * x = s*b (Conjugate transpose) + + [in] DIAG + + DIAG is CHARACTER*1 + Specifies whether or not the matrix A is unit triangular. + = 'N': Non-unit triangular + = 'U': Unit triangular + + [in] NORMIN + + NORMIN is CHARACTER*1 + Specifies whether CNORM has been set or not. + = 'Y': CNORM contains the column norms on entry + = 'N': CNORM is not set on entry. On exit, the norms will + be computed and stored in CNORM. + + [in] N + + N is INTEGER + The order of the matrix A. N >= 0. + + [in] A + + A is COMPLEX*16 array, dimension (LDA,N) + The triangular matrix A. If UPLO = 'U', the leading n by n + upper triangular part of the array A contains the upper + triangular matrix, and the strictly lower triangular part of + A is not referenced. If UPLO = 'L', the leading n by n lower + triangular part of the array A contains the lower triangular + matrix, and the strictly upper triangular part of A is not + referenced. If DIAG = 'U', the diagonal elements of A are + also not referenced and are assumed to be 1. + + [in] LDA + + LDA is INTEGER + The leading dimension of the array A. LDA >= max (1,N). + + [in,out] X + + X is COMPLEX*16 array, dimension (N) + On entry, the right hand side b of the triangular system. + On exit, X is overwritten by the solution vector x. + + [out] SCALE + + SCALE is DOUBLE PRECISION + The scaling factor s for the triangular system + A * x = s*b, A**T * x = s*b, or A**H * x = s*b. + If SCALE = 0, the matrix A is singular or badly scaled, and + the vector x is an exact or approximate solution to A*x = 0. + + [in,out] CNORM + + CNORM is or output) DOUBLE PRECISION array, dimension (N) + + If NORMIN = 'Y', CNORM is an input argument and CNORM(j) + contains the norm of the off-diagonal part of the j-th column + of A. If TRANS = 'N', CNORM(j) must be greater than or equal + to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) + must be greater than or equal to the 1-norm. + + If NORMIN = 'N', CNORM is an output argument and CNORM(j) + returns the 1-norm of the offdiagonal part of the j-th column + of A. + + [out] INFO + + INFO is INTEGER + = 0: successful exit + < 0: if INFO = -k, the k-th argument had an illegal value + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + + Further Details: + ===================== + + A rough bound on x is computed; if that is less than overflow, ZTRSV + is called, otherwise, specific code is used which checks for possible + overflow or divide-by-zero at every operation. + + A columnwise scheme is used for solving A*x = b. The basic algorithm + if A is lower triangular is + + x[1:n] := b[1:n] + for j = 1, ..., n + x(j) := x(j) / A(j,j) + x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] + end + + Define bounds on the components of x after j iterations of the loop: + M(j) = bound on x[1:j] + G(j) = bound on x[j+1:n] + Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. + + Then for iteration j+1 we have + M(j+1) <= G(j) / | A(j+1,j+1) | + G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | + <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) + + where CNORM(j+1) is greater than or equal to the infinity-norm of + column j+1 of A, not counting the diagonal. Hence + + G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) + 1<=i<=j + and + + |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) + 1<=i< j + + Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the + reciprocal of the largest M(j), j=1,..,n, is larger than + max(underflow, 1/overflow). + + The bound on x(j) is also used to determine when a step in the + columnwise method can be performed without fear of overflow. If + the computed bound is greater than a large constant, x is scaled to + prevent overflow, but if the bound overflows, x is set to 0, x(j) to + 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. + + Similarly, a row-wise scheme is used to solve A**T *x = b or + A**H *x = b. The basic algorithm for A upper triangular is + + for j = 1, ..., n + x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) + end + + We simultaneously compute two bounds + G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j + M(j) = bound on x(i), 1<=i<=j + + The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we + add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. + Then the bound on x(j) is + + M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | + + <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) + 1<=i<=j + + and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater + than max(underflow, 1/overflow). + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, + $ CNORM, INFO ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER DIAG, NORMIN, TRANS, UPLO + INTEGER INFO, LDA, N + DOUBLE PRECISION SCALE +* .. +* .. Array Arguments .. + DOUBLE PRECISION CNORM( * ) + COMPLEX*16 A( LDA, * ), X( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, + $ TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN, NOUNIT, UPPER + INTEGER I, IMAX, J, JFIRST, JINC, JLAST + DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL, + $ XBND, XJ, XMAX + COMPLEX*16 CSUMJ, TJJS, USCAL, ZDUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX, IZAMAX + DOUBLE PRECISION DLAMCH, DZASUM + COMPLEX*16 ZDOTC, ZDOTU, ZLADIV + EXTERNAL LSAME, IDAMAX, IZAMAX, DLAMCH, DZASUM, ZDOTC, + $ ZDOTU, ZLADIV +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, XERBLA, ZAXPY, ZDSCAL, ZTRSV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1, CABS2 +* .. +* .. Statement Function definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) + CABS2( ZDUM ) = ABS( DBLE( ZDUM ) / 2.D0 ) + + $ ABS( DIMAG( ZDUM ) / 2.D0 ) +* .. +* .. Executable Statements .. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + NOTRAN = LSAME( TRANS, 'N' ) + NOUNIT = LSAME( DIAG, 'N' ) +* +* Test the input parameters. +* + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN + INFO = -3 + ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. + $ LSAME( NORMIN, 'N' ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLATRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine machine dependent parameters to control overflow. +* + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SMLNUM / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM + SCALE = ONE +* + IF( LSAME( NORMIN, 'N' ) ) THEN +* +* Compute the 1-norm of each column, not including the diagonal. +* + IF( UPPER ) THEN +* +* A is upper triangular. +* + DO 10 J = 1, N + CNORM( J ) = DZASUM( J-1, A( 1, J ), 1 ) + 10 CONTINUE + ELSE +* +* A is lower triangular. +* + DO 20 J = 1, N - 1 + CNORM( J ) = DZASUM( N-J, A( J+1, J ), 1 ) + 20 CONTINUE + CNORM( N ) = ZERO + END IF + END IF +* +* Scale the column norms by TSCAL if the maximum element in CNORM is +* greater than BIGNUM/2. +* + IMAX = IDAMAX( N, CNORM, 1 ) + TMAX = CNORM( IMAX ) + IF( TMAX.LE.BIGNUM*HALF ) THEN + TSCAL = ONE + ELSE + TSCAL = HALF / ( SMLNUM*TMAX ) + CALL DSCAL( N, TSCAL, CNORM, 1 ) + END IF +* +* Compute a bound on the computed solution vector to see if the +* Level 2 BLAS routine ZTRSV can be used. +* + XMAX = ZERO + DO 30 J = 1, N + XMAX = MAX( XMAX, CABS2( X( J ) ) ) + 30 CONTINUE + XBND = XMAX +* + IF( NOTRAN ) THEN +* +* Compute the growth in A * x = b. +* + IF( UPPER ) THEN + JFIRST = N + JLAST = 1 + JINC = -1 + ELSE + JFIRST = 1 + JLAST = N + JINC = 1 + END IF +* + IF( TSCAL.NE.ONE ) THEN + GROW = ZERO + GO TO 60 + END IF +* + IF( NOUNIT ) THEN +* +* A is non-unit triangular. +* +* Compute GROW = 1/G(j) and XBND = 1/M(j). +* Initially, G(0) = max{x(i), i=1,...,n}. +* + GROW = HALF / MAX( XBND, SMLNUM ) + XBND = GROW + DO 40 J = JFIRST, JLAST, JINC +* +* Exit the loop if the growth factor is too small. +* + IF( GROW.LE.SMLNUM ) + $ GO TO 60 +* + TJJS = A( J, J ) + TJJ = CABS1( TJJS ) +* + IF( TJJ.GE.SMLNUM ) THEN +* +* M(j) = G(j-1) / abs(A(j,j)) +* + XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) + ELSE +* +* M(j) could overflow, set XBND to 0. +* + XBND = ZERO + END IF +* + IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN +* +* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) +* + GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) + ELSE +* +* G(j) could overflow, set GROW to 0. +* + GROW = ZERO + END IF + 40 CONTINUE + GROW = XBND + ELSE +* +* A is unit triangular. +* +* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. +* + GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) ) + DO 50 J = JFIRST, JLAST, JINC +* +* Exit the loop if the growth factor is too small. +* + IF( GROW.LE.SMLNUM ) + $ GO TO 60 +* +* G(j) = G(j-1)*( 1 + CNORM(j) ) +* + GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) + 50 CONTINUE + END IF + 60 CONTINUE +* + ELSE +* +* Compute the growth in A**T * x = b or A**H * x = b. +* + IF( UPPER ) THEN + JFIRST = 1 + JLAST = N + JINC = 1 + ELSE + JFIRST = N + JLAST = 1 + JINC = -1 + END IF +* + IF( TSCAL.NE.ONE ) THEN + GROW = ZERO + GO TO 90 + END IF +* + IF( NOUNIT ) THEN +* +* A is non-unit triangular. +* +* Compute GROW = 1/G(j) and XBND = 1/M(j). +* Initially, M(0) = max{x(i), i=1,...,n}. +* + GROW = HALF / MAX( XBND, SMLNUM ) + XBND = GROW + DO 70 J = JFIRST, JLAST, JINC +* +* Exit the loop if the growth factor is too small. +* + IF( GROW.LE.SMLNUM ) + $ GO TO 90 +* +* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) +* + XJ = ONE + CNORM( J ) + GROW = MIN( GROW, XBND / XJ ) +* + TJJS = A( J, J ) + TJJ = CABS1( TJJS ) +* + IF( TJJ.GE.SMLNUM ) THEN +* +* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) +* + IF( XJ.GT.TJJ ) + $ XBND = XBND*( TJJ / XJ ) + ELSE +* +* M(j) could overflow, set XBND to 0. +* + XBND = ZERO + END IF + 70 CONTINUE + GROW = MIN( GROW, XBND ) + ELSE +* +* A is unit triangular. +* +* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. +* + GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) ) + DO 80 J = JFIRST, JLAST, JINC +* +* Exit the loop if the growth factor is too small. +* + IF( GROW.LE.SMLNUM ) + $ GO TO 90 +* +* G(j) = ( 1 + CNORM(j) )*G(j-1) +* + XJ = ONE + CNORM( J ) + GROW = GROW / XJ + 80 CONTINUE + END IF + 90 CONTINUE + END IF +* + IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN +* +* Use the Level 2 BLAS solve if the reciprocal of the bound on +* elements of X is not too small. +* + CALL ZTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 ) + ELSE +* +* Use a Level 1 BLAS solve, scaling intermediate results. +* + IF( XMAX.GT.BIGNUM*HALF ) THEN +* +* Scale X so that its components are less than or equal to +* BIGNUM in absolute value. +* + SCALE = ( BIGNUM*HALF ) / XMAX + CALL ZDSCAL( N, SCALE, X, 1 ) + XMAX = BIGNUM + ELSE + XMAX = XMAX*TWO + END IF +* + IF( NOTRAN ) THEN +* +* Solve A * x = b +* + DO 120 J = JFIRST, JLAST, JINC +* +* Compute x(j) = b(j) / A(j,j), scaling x if necessary. +* + XJ = CABS1( X( J ) ) + IF( NOUNIT ) THEN + TJJS = A( J, J )*TSCAL + ELSE + TJJS = TSCAL + IF( TSCAL.EQ.ONE ) + $ GO TO 110 + END IF + TJJ = CABS1( TJJS ) + IF( TJJ.GT.SMLNUM ) THEN +* +* abs(A(j,j)) > SMLNUM: +* + IF( TJJ.LT.ONE ) THEN + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale x by 1/b(j). +* + REC = ONE / XJ + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF + X( J ) = ZLADIV( X( J ), TJJS ) + XJ = CABS1( X( J ) ) + ELSE IF( TJJ.GT.ZERO ) THEN +* +* 0 < abs(A(j,j)) <= SMLNUM: +* + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM +* to avoid overflow when dividing by A(j,j). +* + REC = ( TJJ*BIGNUM ) / XJ + IF( CNORM( J ).GT.ONE ) THEN +* +* Scale by 1/CNORM(j) to avoid overflow when +* multiplying x(j) times column j. +* + REC = REC / CNORM( J ) + END IF + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + X( J ) = ZLADIV( X( J ), TJJS ) + XJ = CABS1( X( J ) ) + ELSE +* +* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and +* scale = 0, and compute a solution to A*x = 0. +* + DO 100 I = 1, N + X( I ) = ZERO + 100 CONTINUE + X( J ) = ONE + XJ = ONE + SCALE = ZERO + XMAX = ZERO + END IF + 110 CONTINUE +* +* Scale x if necessary to avoid overflow when adding a +* multiple of column j of A. +* + IF( XJ.GT.ONE ) THEN + REC = ONE / XJ + IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN +* +* Scale x by 1/(2*abs(x(j))). +* + REC = REC*HALF + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + END IF + ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN +* +* Scale x by 1/2. +* + CALL ZDSCAL( N, HALF, X, 1 ) + SCALE = SCALE*HALF + END IF +* + IF( UPPER ) THEN + IF( J.GT.1 ) THEN +* +* Compute the update +* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) +* + CALL ZAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X, + $ 1 ) + I = IZAMAX( J-1, X, 1 ) + XMAX = CABS1( X( I ) ) + END IF + ELSE + IF( J.LT.N ) THEN +* +* Compute the update +* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) +* + CALL ZAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1, + $ X( J+1 ), 1 ) + I = J + IZAMAX( N-J, X( J+1 ), 1 ) + XMAX = CABS1( X( I ) ) + END IF + END IF + 120 CONTINUE +* + ELSE IF( LSAME( TRANS, 'T' ) ) THEN +* +* Solve A**T * x = b +* + DO 170 J = JFIRST, JLAST, JINC +* +* Compute x(j) = b(j) - sum A(k,j)*x(k). +* k<>j +* + XJ = CABS1( X( J ) ) + USCAL = TSCAL + REC = ONE / MAX( XMAX, ONE ) + IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN +* +* If x(j) could overflow, scale x by 1/(2*XMAX). +* + REC = REC*HALF + IF( NOUNIT ) THEN + TJJS = A( J, J )*TSCAL + ELSE + TJJS = TSCAL + END IF + TJJ = CABS1( TJJS ) + IF( TJJ.GT.ONE ) THEN +* +* Divide by A(j,j) when scaling x if A(j,j) > 1. +* + REC = MIN( ONE, REC*TJJ ) + USCAL = ZLADIV( USCAL, TJJS ) + END IF + IF( REC.LT.ONE ) THEN + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF +* + CSUMJ = ZERO + IF( USCAL.EQ.DCMPLX( ONE ) ) THEN +* +* If the scaling needed for A in the dot product is 1, +* call ZDOTU to perform the dot product. +* + IF( UPPER ) THEN + CSUMJ = ZDOTU( J-1, A( 1, J ), 1, X, 1 ) + ELSE IF( J.LT.N ) THEN + CSUMJ = ZDOTU( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) + END IF + ELSE +* +* Otherwise, use in-line code for the dot product. +* + IF( UPPER ) THEN + DO 130 I = 1, J - 1 + CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I ) + 130 CONTINUE + ELSE IF( J.LT.N ) THEN + DO 140 I = J + 1, N + CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I ) + 140 CONTINUE + END IF + END IF +* + IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN +* +* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) +* was not used to scale the dotproduct. +* + X( J ) = X( J ) - CSUMJ + XJ = CABS1( X( J ) ) + IF( NOUNIT ) THEN + TJJS = A( J, J )*TSCAL + ELSE + TJJS = TSCAL + IF( TSCAL.EQ.ONE ) + $ GO TO 160 + END IF +* +* Compute x(j) = x(j) / A(j,j), scaling if necessary. +* + TJJ = CABS1( TJJS ) + IF( TJJ.GT.SMLNUM ) THEN +* +* abs(A(j,j)) > SMLNUM: +* + IF( TJJ.LT.ONE ) THEN + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale X by 1/abs(x(j)). +* + REC = ONE / XJ + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF + X( J ) = ZLADIV( X( J ), TJJS ) + ELSE IF( TJJ.GT.ZERO ) THEN +* +* 0 < abs(A(j,j)) <= SMLNUM: +* + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. +* + REC = ( TJJ*BIGNUM ) / XJ + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + X( J ) = ZLADIV( X( J ), TJJS ) + ELSE +* +* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and +* scale = 0 and compute a solution to A**T *x = 0. +* + DO 150 I = 1, N + X( I ) = ZERO + 150 CONTINUE + X( J ) = ONE + SCALE = ZERO + XMAX = ZERO + END IF + 160 CONTINUE + ELSE +* +* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot +* product has already been divided by 1/A(j,j). +* + X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ + END IF + XMAX = MAX( XMAX, CABS1( X( J ) ) ) + 170 CONTINUE +* + ELSE +* +* Solve A**H * x = b +* + DO 220 J = JFIRST, JLAST, JINC +* +* Compute x(j) = b(j) - sum A(k,j)*x(k). +* k<>j +* + XJ = CABS1( X( J ) ) + USCAL = TSCAL + REC = ONE / MAX( XMAX, ONE ) + IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN +* +* If x(j) could overflow, scale x by 1/(2*XMAX). +* + REC = REC*HALF + IF( NOUNIT ) THEN + TJJS = DCONJG( A( J, J ) )*TSCAL + ELSE + TJJS = TSCAL + END IF + TJJ = CABS1( TJJS ) + IF( TJJ.GT.ONE ) THEN +* +* Divide by A(j,j) when scaling x if A(j,j) > 1. +* + REC = MIN( ONE, REC*TJJ ) + USCAL = ZLADIV( USCAL, TJJS ) + END IF + IF( REC.LT.ONE ) THEN + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF +* + CSUMJ = ZERO + IF( USCAL.EQ.DCMPLX( ONE ) ) THEN +* +* If the scaling needed for A in the dot product is 1, +* call ZDOTC to perform the dot product. +* + IF( UPPER ) THEN + CSUMJ = ZDOTC( J-1, A( 1, J ), 1, X, 1 ) + ELSE IF( J.LT.N ) THEN + CSUMJ = ZDOTC( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) + END IF + ELSE +* +* Otherwise, use in-line code for the dot product. +* + IF( UPPER ) THEN + DO 180 I = 1, J - 1 + CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )* + $ X( I ) + 180 CONTINUE + ELSE IF( J.LT.N ) THEN + DO 190 I = J + 1, N + CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )* + $ X( I ) + 190 CONTINUE + END IF + END IF +* + IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN +* +* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) +* was not used to scale the dotproduct. +* + X( J ) = X( J ) - CSUMJ + XJ = CABS1( X( J ) ) + IF( NOUNIT ) THEN + TJJS = DCONJG( A( J, J ) )*TSCAL + ELSE + TJJS = TSCAL + IF( TSCAL.EQ.ONE ) + $ GO TO 210 + END IF +* +* Compute x(j) = x(j) / A(j,j), scaling if necessary. +* + TJJ = CABS1( TJJS ) + IF( TJJ.GT.SMLNUM ) THEN +* +* abs(A(j,j)) > SMLNUM: +* + IF( TJJ.LT.ONE ) THEN + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale X by 1/abs(x(j)). +* + REC = ONE / XJ + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + END IF + X( J ) = ZLADIV( X( J ), TJJS ) + ELSE IF( TJJ.GT.ZERO ) THEN +* +* 0 < abs(A(j,j)) <= SMLNUM: +* + IF( XJ.GT.TJJ*BIGNUM ) THEN +* +* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. +* + REC = ( TJJ*BIGNUM ) / XJ + CALL ZDSCAL( N, REC, X, 1 ) + SCALE = SCALE*REC + XMAX = XMAX*REC + END IF + X( J ) = ZLADIV( X( J ), TJJS ) + ELSE +* +* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and +* scale = 0 and compute a solution to A**H *x = 0. +* + DO 200 I = 1, N + X( I ) = ZERO + 200 CONTINUE + X( J ) = ONE + SCALE = ZERO + XMAX = ZERO + END IF + 210 CONTINUE + ELSE +* +* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot +* product has already been divided by 1/A(j,j). +* + X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ + END IF + XMAX = MAX( XMAX, CABS1( X( J ) ) ) + 220 CONTINUE + END IF + SCALE = SCALE / TSCAL + END IF +* +* Scale the column norms by 1/TSCAL for return. +* + IF( TSCAL.NE.ONE ) THEN + CALL DSCAL( N, ONE / TSCAL, CNORM, 1 ) + END IF +* + RETURN +* +* End of ZLATRS +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zlatrs} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zrot LAPACK} +%\pagehead{zrot}{zrot} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zrot.input} +)set break resume +)sys rm -f zrot.output +)spool zrot.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zrot.help} +==================================================================== +zrot examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S ) + + .. Scalar Arguments .. + INTEGER INCX, INCY, N + DOUBLE PRECISION C + COMPLEX*16 S + .. + .. Array Arguments .. + COMPLEX*16 CX( * ), CY( * ) + .. + + + Purpose: + ============= + + ZROT applies a plane rotation, where the cos (C) is real and the + sin (S) is complex, and the vectors CX and CY are complex. + + Arguments: + ========== + + [in] N + + N is INTEGER + The number of elements in the vectors CX and CY. + + [in,out] CX + + CX is COMPLEX*16 array, dimension (N) + On input, the vector X. + On output, CX is overwritten with C*X + S*Y. + + [in] INCX + + INCX is INTEGER + The increment between successive values of CY. INCX <> 0. + + [in,out] CY + + CY is COMPLEX*16 array, dimension (N) + On input, the vector Y. + On output, CY is overwritten with -CONJG(S)*X + C*Y. + + [in] INCY + + INCY is INTEGER + The increment between successive values of CY. INCX <> 0. + + [in] C + + C is DOUBLE PRECISION + + [in] S + + S is COMPLEX*16 + C and S define a rotation + [ C S ] + [ -conjg(S) C ] + where C*C + S*CONJG(S) = 1.0. + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S ) +* +* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER INCX, INCY, N + DOUBLE PRECISION C + COMPLEX*16 S +* .. +* .. Array Arguments .. + COMPLEX*16 CX( * ), CY( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IX, IY + COMPLEX*16 STEMP +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. +* .. Executable Statements .. +* + IF( N.LE.0 ) + $ RETURN + IF( INCX.EQ.1 .AND. INCY.EQ.1 ) + $ GO TO 20 +* +* Code for unequal increments or equal increments not equal to 1 +* + IX = 1 + IY = 1 + IF( INCX.LT.0 ) + $ IX = ( -N+1 )*INCX + 1 + IF( INCY.LT.0 ) + $ IY = ( -N+1 )*INCY + 1 + DO 10 I = 1, N + STEMP = C*CX( IX ) + S*CY( IY ) + CY( IY ) = C*CY( IY ) - DCONJG( S )*CX( IX ) + CX( IX ) = STEMP + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +* +* Code for both increments equal to 1 +* + 20 CONTINUE + DO 30 I = 1, N + STEMP = C*CX( I ) + S*CY( I ) + CY( I ) = C*CY( I ) - DCONJG( S )*CX( I ) + CX( I ) = STEMP + 30 CONTINUE + RETURN + END + +\end{verbatim} + +\begin{chunk}{LAPACK zrot} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ztrevc LAPACK} +%\pagehead{ztrevc}{ztrevc} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{ztrevc.input} +)set break resume +)sys rm -f ztrevc.output +)spool ztrevc.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{ztrevc.help} +==================================================================== +ztrevc examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, + LDVR, MM, M, WORK, RWORK, INFO ) + + .. Scalar Arguments .. + CHARACTER HOWMNY, SIDE + INTEGER INFO, LDT, LDVL, LDVR, M, MM, N + .. + .. Array Arguments .. + LOGICAL SELECT( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), + $ WORK( * ) + .. + + + Purpose: + ============= + + ZTREVC computes some or all of the right and/or left eigenvectors of + a complex upper triangular matrix T. + Matrices of this type are produced by the Schur factorization of + a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR. + + The right eigenvector x and the left eigenvector y of T corresponding + to an eigenvalue w are defined by: + + T*x = w*x, (y**H)*T = w*(y**H) + + where y**H denotes the conjugate transpose of the vector y. + The eigenvalues are not input to this routine, but are read directly + from the diagonal of T. + + This routine returns the matrices X and/or Y of right and left + eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an + input matrix. If Q is the unitary factor that reduces a matrix A to + Schur form T, then Q*X and Q*Y are the matrices of right and left + eigenvectors of A. + + Arguments: + ========== + + [in] SIDE + + SIDE is CHARACTER*1 + = 'R': compute right eigenvectors only; + = 'L': compute left eigenvectors only; + = 'B': compute both right and left eigenvectors. + + [in] HOWMNY + + HOWMNY is CHARACTER*1 + = 'A': compute all right and/or left eigenvectors; + = 'B': compute all right and/or left eigenvectors, + backtransformed using the matrices supplied in + VR and/or VL; + = 'S': compute selected right and/or left eigenvectors, + as indicated by the logical array SELECT. + + [in] SELECT + + SELECT is LOGICAL array, dimension (N) + If HOWMNY = 'S', SELECT specifies the eigenvectors to be + computed. + The eigenvector corresponding to the j-th eigenvalue is + computed if SELECT(j) = .TRUE.. + Not referenced if HOWMNY = 'A' or 'B'. + + [in] N + + N is INTEGER + The order of the matrix T. N >= 0. + + [in,out] T + + T is COMPLEX*16 array, dimension (LDT,N) + The upper triangular matrix T. T is modified, but restored + on exit. + + [in] LDT + + LDT is INTEGER + The leading dimension of the array T. LDT >= max(1,N). + + [in,out] VL + + VL is COMPLEX*16 array, dimension (LDVL,MM) + On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must + contain an N-by-N matrix Q (usually the unitary matrix Q of + Schur vectors returned by ZHSEQR). + On exit, if SIDE = 'L' or 'B', VL contains: + if HOWMNY = 'A', the matrix Y of left eigenvectors of T; + if HOWMNY = 'B', the matrix Q*Y; + if HOWMNY = 'S', the left eigenvectors of T specified by + SELECT, stored consecutively in the columns + of VL, in the same order as their + eigenvalues. + Not referenced if SIDE = 'R'. + + [in] LDVL + + LDVL is INTEGER + The leading dimension of the array VL. LDVL >= 1, and if + SIDE = 'L' or 'B', LDVL >= N. + + [in,out] VR + + VR is COMPLEX*16 array, dimension (LDVR,MM) + On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must + contain an N-by-N matrix Q (usually the unitary matrix Q of + Schur vectors returned by ZHSEQR). + On exit, if SIDE = 'R' or 'B', VR contains: + if HOWMNY = 'A', the matrix X of right eigenvectors of T; + if HOWMNY = 'B', the matrix Q*X; + if HOWMNY = 'S', the right eigenvectors of T specified by + SELECT, stored consecutively in the columns + of VR, in the same order as their + eigenvalues. + Not referenced if SIDE = 'L'. + + [in] LDVR + + LDVR is INTEGER + The leading dimension of the array VR. LDVR >= 1, and if + SIDE = 'R' or 'B'; LDVR >= N. + + [in] MM + + MM is INTEGER + The number of columns in the arrays VL and/or VR. MM >= M. + + [out] M + + M is INTEGER + The number of columns in the arrays VL and/or VR actually + used to store the eigenvectors. If HOWMNY = 'A' or 'B', M + is set to N. Each selected eigenvector occupies one + column. + + [out] WORK + + WORK is COMPLEX*16 array, dimension (2*N) + + [out] RWORK + + RWORK is DOUBLE PRECISION array, dimension (N) + + [out] INFO + + INFO is INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + + Further Details: + ===================== + + The algorithm used in this program is basically backward (forward) + substitution, with scaling to make the the code robust against + possible overflow. + + Each eigenvector is normalized so that the element of largest + magnitude has magnitude 1; here the magnitude of a complex number + (x,y) is taken to be |x| + |y|. + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, + $ LDVR, MM, M, WORK, RWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER HOWMNY, SIDE + INTEGER INFO, LDT, LDVL, LDVR, M, MM, N +* .. +* .. Array Arguments .. + LOGICAL SELECT( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CMZERO, CMONE + PARAMETER ( CMZERO = ( 0.0D+0, 0.0D+0 ), + $ CMONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV + INTEGER I, II, IS, J, K, KI + DOUBLE PRECISION OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL + COMPLEX*16 CDUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH, DZASUM + EXTERNAL LSAME, IZAMAX, DLAMCH, DZASUM +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLATRS +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters +* + BOTHV = LSAME( SIDE, 'B' ) + RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV + LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV +* + ALLV = LSAME( HOWMNY, 'A' ) + OVER = LSAME( HOWMNY, 'B' ) + SOMEV = LSAME( HOWMNY, 'S' ) +* +* Set M to the number of columns required to store the selected +* eigenvectors. +* + IF( SOMEV ) THEN + M = 0 + DO 10 J = 1, N + IF( SELECT( J ) ) + $ M = M + 1 + 10 CONTINUE + ELSE + M = N + END IF +* + INFO = 0 + IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN + INFO = -1 + ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN + INFO = -10 + ELSE IF( MM.LT.M ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTREVC', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* +* Set the constants to control overflow. +* + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Precision' ) + SMLNUM = UNFL*( N / ULP ) +* +* Store the diagonal elements of T in working array WORK. +* + DO 20 I = 1, N + WORK( I+N ) = T( I, I ) + 20 CONTINUE +* +* Compute 1-norm of each column of strictly upper triangular +* part of T to control overflow in triangular solver. +* + RWORK( 1 ) = ZERO + DO 30 J = 2, N + RWORK( J ) = DZASUM( J-1, T( 1, J ), 1 ) + 30 CONTINUE +* + IF( RIGHTV ) THEN +* +* Compute right eigenvectors. +* + IS = M + DO 80 KI = N, 1, -1 +* + IF( SOMEV ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 80 + END IF + SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) +* + WORK( 1 ) = CMONE +* +* Form right-hand side. +* + DO 40 K = 1, KI - 1 + WORK( K ) = -T( K, KI ) + 40 CONTINUE +* +* Solve the triangular system: +* (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. +* + DO 50 K = 1, KI - 1 + T( K, K ) = T( K, K ) - T( KI, KI ) + IF( CABS1( T( K, K ) ).LT.SMIN ) + $ T( K, K ) = SMIN + 50 CONTINUE +* + IF( KI.GT.1 ) THEN + CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', 'Y', + $ KI-1, T, LDT, WORK( 1 ), SCALE, RWORK, + $ INFO ) + WORK( KI ) = SCALE + END IF +* +* Copy the vector x or Q*x to VR and normalize. +* + IF( .NOT.OVER ) THEN + CALL ZCOPY( KI, WORK( 1 ), 1, VR( 1, IS ), 1 ) +* + II = IZAMAX( KI, VR( 1, IS ), 1 ) + REMAX = ONE / CABS1( VR( II, IS ) ) + CALL ZDSCAL( KI, REMAX, VR( 1, IS ), 1 ) +* + DO 60 K = KI + 1, N + VR( K, IS ) = CMZERO + 60 CONTINUE + ELSE + IF( KI.GT.1 ) + $ CALL ZGEMV( 'N', N, KI-1, CMONE, VR, LDVR, WORK( 1 ), + $ 1, DCMPLX( SCALE ), VR( 1, KI ), 1 ) +* + II = IZAMAX( N, VR( 1, KI ), 1 ) + REMAX = ONE / CABS1( VR( II, KI ) ) + CALL ZDSCAL( N, REMAX, VR( 1, KI ), 1 ) + END IF +* +* Set back the original diagonal elements of T. +* + DO 70 K = 1, KI - 1 + T( K, K ) = WORK( K+N ) + 70 CONTINUE +* + IS = IS - 1 + 80 CONTINUE + END IF +* + IF( LEFTV ) THEN +* +* Compute left eigenvectors. +* + IS = 1 + DO 130 KI = 1, N +* + IF( SOMEV ) THEN + IF( .NOT.SELECT( KI ) ) + $ GO TO 130 + END IF + SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) +* + WORK( N ) = CMONE +* +* Form right-hand side. +* + DO 90 K = KI + 1, N + WORK( K ) = -DCONJG( T( KI, K ) ) + 90 CONTINUE +* +* Solve the triangular system: +* (T(KI+1:N,KI+1:N) - T(KI,KI))**H * X = SCALE*WORK. +* + DO 100 K = KI + 1, N + T( K, K ) = T( K, K ) - T( KI, KI ) + IF( CABS1( T( K, K ) ).LT.SMIN ) + $ T( K, K ) = SMIN + 100 CONTINUE +* + IF( KI.LT.N ) THEN + CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit', + $ 'Y', N-KI, T( KI+1, KI+1 ), LDT, + $ WORK( KI+1 ), SCALE, RWORK, INFO ) + WORK( KI ) = SCALE + END IF +* +* Copy the vector x or Q*x to VL and normalize. +* + IF( .NOT.OVER ) THEN + CALL ZCOPY( N-KI+1, WORK( KI ), 1, VL( KI, IS ), 1 ) +* + II = IZAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 + REMAX = ONE / CABS1( VL( II, IS ) ) + CALL ZDSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) +* + DO 110 K = 1, KI - 1 + VL( K, IS ) = CMZERO + 110 CONTINUE + ELSE + IF( KI.LT.N ) + $ CALL ZGEMV( 'N', N, N-KI, CMONE, VL( 1, KI+1 ), LDVL, + $ WORK( KI+1 ), 1, DCMPLX( SCALE ), + $ VL( 1, KI ), 1 ) +* + II = IZAMAX( N, VL( 1, KI ), 1 ) + REMAX = ONE / CABS1( VL( II, KI ) ) + CALL ZDSCAL( N, REMAX, VL( 1, KI ), 1 ) + END IF +* +* Set back the original diagonal elements of T. +* + DO 120 K = KI + 1, N + T( K, K ) = WORK( K+N ) + 120 CONTINUE +* + IS = IS + 1 + 130 CONTINUE + END IF +* + RETURN +* +* End of ZTREVC +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK ztrevc} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ztrexc LAPACK} +%\pagehead{ztrexc}{ztrexc} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{ztrexc.input} +)set break resume +)sys rm -f ztrexc.output +)spool ztrexc.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{ztrexc.help} +==================================================================== +ztrexc examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) + + .. Scalar Arguments .. + CHARACTER COMPQ + INTEGER IFST, ILST, INFO, LDQ, LDT, N + .. + .. Array Arguments .. + COMPLEX*16 Q( LDQ, * ), T( LDT, * ) + .. + + + Purpose: + ============= + + ZTREXC reorders the Schur factorization of a complex matrix + A = Q*T*Q**H, so that the diagonal element of T with row index IFST + is moved to row ILST. + + The Schur form T is reordered by a unitary similarity transformation + Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by + postmultplying it with Z. + + Arguments: + ========== + + [in] COMPQ + + COMPQ is CHARACTER*1 + = 'V': update the matrix Q of Schur vectors; + = 'N': do not update Q. + + [in] N + + N is INTEGER + The order of the matrix T. N >= 0. + + [in,out] T + + T is COMPLEX*16 array, dimension (LDT,N) + On entry, the upper triangular matrix T. + On exit, the reordered upper triangular matrix. + + [in] LDT + + LDT is INTEGER + The leading dimension of the array T. LDT >= max(1,N). + + [in,out] Q + + Q is COMPLEX*16 array, dimension (LDQ,N) + On entry, if COMPQ = 'V', the matrix Q of Schur vectors. + On exit, if COMPQ = 'V', Q has been postmultiplied by the + unitary transformation matrix Z which reorders T. + If COMPQ = 'N', Q is not referenced. + + [in] LDQ + + LDQ is INTEGER + The leading dimension of the array Q. LDQ >= max(1,N). + + [in] IFST + + IFST is INTEGER + + [in] ILST + + ILST is INTEGER + + Specify the reordering of the diagonal elements of T: + The element with row index IFST is moved to row ILST by a + sequence of transpositions between adjacent elements. + 1 <= IFST <= N; 1 <= ILST <= N. + + [out] INFO + + INFO is INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER COMPQ + INTEGER IFST, ILST, INFO, LDQ, LDT, N +* .. +* .. Array Arguments .. + COMPLEX*16 Q( LDQ, * ), T( LDT, * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL WANTQ + INTEGER K, M1, M2, M3 + DOUBLE PRECISION CS + COMPLEX*16 SN, T11, T22, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARTG, ZROT +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters. +* + INFO = 0 + WANTQ = LSAME( COMPQ, 'V' ) + IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN + INFO = -6 + ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN + INFO = -7 + ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTREXC', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.1 .OR. IFST.EQ.ILST ) + $ RETURN +* + IF( IFST.LT.ILST ) THEN +* +* Move the IFST-th diagonal element forward down the diagonal. +* + M1 = 0 + M2 = -1 + M3 = 1 + ELSE +* +* Move the IFST-th diagonal element backward up the diagonal. +* + M1 = -1 + M2 = 0 + M3 = -1 + END IF +* + DO 10 K = IFST + M1, ILST + M2, M3 +* +* Interchange the k-th and (k+1)-th diagonal elements. +* + T11 = T( K, K ) + T22 = T( K+1, K+1 ) +* +* Determine the transformation to perform the interchange. +* + CALL ZLARTG( T( K, K+1 ), T22-T11, CS, SN, TEMP ) +* +* Apply transformation to the matrix T. +* + IF( K+2.LE.N ) + $ CALL ZROT( N-K-1, T( K, K+2 ), LDT, T( K+1, K+2 ), LDT, CS, + $ SN ) + CALL ZROT( K-1, T( 1, K ), 1, T( 1, K+1 ), 1, CS, + $ DCONJG( SN ) ) +* + T( K, K ) = T22 + T( K+1, K+1 ) = T11 +* + IF( WANTQ ) THEN +* +* Accumulate transformation in the matrix Q. +* + CALL ZROT( N, Q( 1, K ), 1, Q( 1, K+1 ), 1, CS, + $ DCONJG( SN ) ) + END IF +* + 10 CONTINUE +* + RETURN +* +* End of ZTREXC +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK ztrexc} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zung2r LAPACK} +%\pagehead{zung2r}{zung2r} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zung2r.input} +)set break resume +)sys rm -f zung2r.output +)spool zung2r.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zung2r.help} +==================================================================== +zung2r examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) + + .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N + .. + .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) + .. + + + Purpose: + ============= + + ZUNG2R generates an m by n complex matrix Q with orthonormal columns, + which is defined as the first n columns of a product of k elementary + reflectors of order m + + Q = H(1) H(2) . . . H(k) + + as returned by ZGEQRF. + + Arguments: + ========== + + [in] M + + M is INTEGER + The number of rows of the matrix Q. M >= 0. + + [in] N + + N is INTEGER + The number of columns of the matrix Q. M >= N >= 0. + + [in] K + + K is INTEGER + The number of elementary reflectors whose product defines the + matrix Q. N >= K >= 0. + + [in,out] A + + A is COMPLEX*16 array, dimension (LDA,N) + On entry, the i-th column must contain the vector which + defines the elementary reflector H(i), for i = 1,2,...,k, as + returned by ZGEQRF in the first k columns of its array + argument A. + On exit, the m by n matrix Q. + + [in] LDA + + LDA is INTEGER + The first dimension of the array A. LDA >= max(1,M). + + [in] TAU + + TAU is COMPLEX*16 array, dimension (K) + TAU(i) must contain the scalar factor of the elementary + reflector H(i), as returned by ZGEQRF. + + [out] WORK + + WORK is COMPLEX*16 array, dimension (N) + + [out] INFO + + INFO is INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument has an illegal value + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, J, L +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF, ZSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNG2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* +* Initialise columns k+1:n to columns of the unit matrix +* + DO 20 J = K + 1, N + DO 10 L = 1, M + A( L, J ) = ZERO + 10 CONTINUE + A( J, J ) = ONE + 20 CONTINUE +* + DO 40 I = K, 1, -1 +* +* Apply H(i) to A(i:m,i:n) from the left +* + IF( I.LT.N ) THEN + A( I, I ) = ONE + CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) + END IF + IF( I.LT.M ) + $ CALL ZSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) + A( I, I ) = ONE - TAU( I ) +* +* Set A(1:i-1,i) to zero +* + DO 30 L = 1, I - 1 + A( L, I ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of ZUNG2R +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zung2r} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zunghr LAPACK} +%\pagehead{zunghr}{zunghr} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zunghr.input} +)set break resume +)sys rm -f zunghr.output +)spool zunghr.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zunghr.help} +==================================================================== +zunghr examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) + + .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, LWORK, N + .. + .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) + .. + + + Purpose: + ============= + + ZUNGHR generates a complex unitary matrix Q which is defined as the + product of IHI-ILO elementary reflectors of order N, as returned by + ZGEHRD: + + Q = H(ilo) H(ilo+1) . . . H(ihi-1). + + Arguments: + ========== + + [in] N + + N is INTEGER + The order of the matrix Q. N >= 0. + + [in] ILO + + ILO is INTEGER + + [in] IHI + + IHI is INTEGER + + ILO and IHI must have the same values as in the previous call + of ZGEHRD. Q is equal to the unit matrix except in the + submatrix Q(ilo+1:ihi,ilo+1:ihi). + 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. + + [in,out] A + + A is COMPLEX*16 array, dimension (LDA,N) + On entry, the vectors which define the elementary reflectors, + as returned by ZGEHRD. + On exit, the N-by-N unitary matrix Q. + + [in] LDA + + LDA is INTEGER + The leading dimension of the array A. LDA >= max(1,N). + + [in] TAU + + TAU is COMPLEX*16 array, dimension (N-1) + TAU(i) must contain the scalar factor of the elementary + reflector H(i), as returned by ZGEHRD. + + [out] WORK + + WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) + On exit, if INFO = 0, WORK(1) returns the optimal LWORK. + + [in] LWORK + + LWORK is INTEGER + The dimension of the array WORK. LWORK >= IHI-ILO. + For optimum performance LWORK >= (IHI-ILO)*NB, where NB is + the optimal blocksize. + + If LWORK = -1, then a workspace query is assumed; the routine + only calculates the optimal size of the WORK array, returns + this value as the first entry of the WORK array, and no error + message related to LWORK is issued by XERBLA. + + [out] INFO + + INFO is INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IINFO, J, LWKOPT, NB, NH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZUNGQR +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NH = IHI - ILO + LQUERY = ( LWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF +* + IF( INFO.EQ.0 ) THEN + NB = ILAENV( 1, 'ZUNGQR', ' ', NH, NH, NH, -1 ) + LWKOPT = MAX( 1, NH )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNGHR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* Shift the vectors which define the elementary reflectors one +* column to the right, and set the first ilo and the last n-ihi +* rows and columns to those of the unit matrix +* + DO 40 J = IHI, ILO + 1, -1 + DO 10 I = 1, J - 1 + A( I, J ) = ZERO + 10 CONTINUE + DO 20 I = J + 1, IHI + A( I, J ) = A( I, J-1 ) + 20 CONTINUE + DO 30 I = IHI + 1, N + A( I, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + DO 60 J = 1, ILO + DO 50 I = 1, N + A( I, J ) = ZERO + 50 CONTINUE + A( J, J ) = ONE + 60 CONTINUE + DO 80 J = IHI + 1, N + DO 70 I = 1, N + A( I, J ) = ZERO + 70 CONTINUE + A( J, J ) = ONE + 80 CONTINUE +* + IF( NH.GT.0 ) THEN +* +* Generate Q(ilo+1:ihi,ilo+1:ihi) +* + CALL ZUNGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), + $ WORK, LWORK, IINFO ) + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of ZUNGHR +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zunghr} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zungqr LAPACK} +%\pagehead{zungqr}{zungqr} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zungqr.input} +)set break resume +)sys rm -f zungqr.output +)spool zungqr.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zungqr.help} +==================================================================== +zungqr examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) + + .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N + .. + .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) + .. + + + Purpose: + ============= + + ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns, + which is defined as the first N columns of a product of K elementary + reflectors of order M + + Q = H(1) H(2) . . . H(k) + + as returned by ZGEQRF. + + Arguments: + ========== + + [in] M + + M is INTEGER + The number of rows of the matrix Q. M >= 0. + + [in] N + + N is INTEGER + The number of columns of the matrix Q. M >= N >= 0. + + [in] K + + K is INTEGER + The number of elementary reflectors whose product defines the + matrix Q. N >= K >= 0. + + [in,out] A + + A is COMPLEX*16 array, dimension (LDA,N) + On entry, the i-th column must contain the vector which + defines the elementary reflector H(i), for i = 1,2,...,k, as + returned by ZGEQRF in the first k columns of its array + argument A. + On exit, the M-by-N matrix Q. + + [in] LDA + + LDA is INTEGER + The first dimension of the array A. LDA >= max(1,M). + + [in] TAU + + TAU is COMPLEX*16 array, dimension (K) + TAU(i) must contain the scalar factor of the elementary + reflector H(i), as returned by ZGEQRF. + + [out] WORK + + WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) + On exit, if INFO = 0, WORK(1) returns the optimal LWORK. + + [in] LWORK + + LWORK is INTEGER + The dimension of the array WORK. LWORK >= max(1,N). + For optimum performance LWORK >= N*NB, where NB is the + optimal blocksize. + + If LWORK = -1, then a workspace query is assumed; the routine + only calculates the optimal size of the WORK array, returns + this value as the first entry of the WORK array, and no error + message related to LWORK is issued by XERBLA. + + [out] INFO + + INFO is INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument has an illegal value + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, + $ LWKOPT, NB, NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2R +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 ) + LWKOPT = MAX( 1, N )*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNGQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'ZUNGQR', ' ', M, N, K, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQR', ' ', M, N, K, -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code after the last block. +* The first kk columns are handled by the block method. +* + KI = ( ( K-NX-1 ) / NB )*NB + KK = MIN( K, KI+NB ) +* +* Set A(1:kk,kk+1:n) to zero. +* + DO 20 J = KK + 1, N + DO 10 I = 1, KK + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + KK = 0 + END IF +* +* Use unblocked code for the last or only block. +* + IF( KK.LT.N ) + $ CALL ZUNG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, + $ TAU( KK+1 ), WORK, IINFO ) +* + IF( KK.GT.0 ) THEN +* +* Use blocked code +* + DO 50 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF( I+IB.LE.N ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB, + $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H to A(i:m,i+ib:n) from the left +* + CALL ZLARFB( 'Left', 'No transpose', 'Forward', + $ 'Columnwise', M-I+1, N-I-IB+1, IB, + $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), + $ LDA, WORK( IB+1 ), LDWORK ) + END IF +* +* Apply H to rows i:m of current block +* + CALL ZUNG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* +* Set rows 1:i-1 of current block to zero +* + DO 40 J = I, I + IB - 1 + DO 30 L = 1, I - 1 + A( L, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of ZUNGQR +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zungqr} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zunm2r LAPACK} +%\pagehead{zunm2r}{zunm2r} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zunm2r.input} +)set break resume +)sys rm -f zunm2r.output +)spool zunm2r.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zunm2r.help} +==================================================================== +zunm2r examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + WORK, INFO ) + + .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N + .. + .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) + .. + + + Purpose: + ============= + + ZUNM2R overwrites the general complex m-by-n matrix C with + + Q * C if SIDE = 'L' and TRANS = 'N', or + + Q**H* C if SIDE = 'L' and TRANS = 'C', or + + C * Q if SIDE = 'R' and TRANS = 'N', or + + C * Q**H if SIDE = 'R' and TRANS = 'C', + + where Q is a complex unitary matrix defined as the product of k + elementary reflectors + + Q = H(1) H(2) . . . H(k) + + as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n + if SIDE = 'R'. + + Arguments: + ========== + + [in] SIDE + + SIDE is CHARACTER*1 + = 'L': apply Q or Q**H from the Left + = 'R': apply Q or Q**H from the Right + + [in] TRANS + + TRANS is CHARACTER*1 + = 'N': apply Q (No transpose) + = 'C': apply Q**H (Conjugate transpose) + + [in] M + + M is INTEGER + The number of rows of the matrix C. M >= 0. + + [in] N + + N is INTEGER + The number of columns of the matrix C. N >= 0. + + [in] K + + K is INTEGER + The number of elementary reflectors whose product defines + the matrix Q. + If SIDE = 'L', M >= K >= 0; + if SIDE = 'R', N >= K >= 0. + + [in] A + + A is COMPLEX*16 array, dimension (LDA,K) + The i-th column must contain the vector which defines the + elementary reflector H(i), for i = 1,2,...,k, as returned by + ZGEQRF in the first k columns of its array argument A. + A is modified by the routine but restored on exit. + + [in] LDA + + LDA is INTEGER + The leading dimension of the array A. + If SIDE = 'L', LDA >= max(1,M); + if SIDE = 'R', LDA >= max(1,N). + + [in] TAU + + TAU is COMPLEX*16 array, dimension (K) + TAU(i) must contain the scalar factor of the elementary + reflector H(i), as returned by ZGEQRF. + + [in,out] C + + C is COMPLEX*16 array, dimension (LDC,N) + On entry, the m-by-n matrix C. + On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. + + [in] LDC + + LDC is INTEGER + The leading dimension of the array C. LDC >= max(1,M). + + [out] WORK + + WORK is COMPLEX*16 array, dimension + (N) if SIDE = 'L', + (M) if SIDE = 'R' + + [out] INFO + + INFO is INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + COMPLEX*16 AII, TAUI +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNM2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) or H(i)**H is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H(i) or H(i)**H is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H(i) or H(i)**H +* + IF( NOTRAN ) THEN + TAUI = TAU( I ) + ELSE + TAUI = DCONJG( TAU( I ) ) + END IF + AII = A( I, I ) + A( I, I ) = ONE + CALL ZLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC, + $ WORK ) + A( I, I ) = AII + 10 CONTINUE + RETURN +* +* End of ZUNM2R +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zunm2r} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zunmhr LAPACK} +%\pagehead{zunmhr}{zunmhr} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zunmhr.input} +)set break resume +)sys rm -f zunmhr.output +)spool zunmhr.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zunmhr.help} +==================================================================== +zunmhr examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, + LDC, WORK, LWORK, INFO ) + + .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N + .. + .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) + .. + + + Purpose: + ============= + + ZUNMHR overwrites the general complex M-by-N matrix C with + + SIDE = 'L' SIDE = 'R' + TRANS = 'N': Q * C C * Q + TRANS = 'C': Q**H * C C * Q**H + + where Q is a complex unitary matrix of order nq, with nq = m if + SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of + IHI-ILO elementary reflectors, as returned by ZGEHRD: + + Q = H(ilo) H(ilo+1) . . . H(ihi-1). + + Arguments: + ========== + + [in] SIDE + + SIDE is CHARACTER*1 + = 'L': apply Q or Q**H from the Left; + = 'R': apply Q or Q**H from the Right. + + [in] TRANS + + TRANS is CHARACTER*1 + = 'N': apply Q (No transpose) + = 'C': apply Q**H (Conjugate transpose) + + [in] M + + M is INTEGER + The number of rows of the matrix C. M >= 0. + + [in] N + + N is INTEGER + The number of columns of the matrix C. N >= 0. + + [in] ILO + + ILO is INTEGER + + [in] IHI + + IHI is INTEGER + + ILO and IHI must have the same values as in the previous call + of ZGEHRD. Q is equal to the unit matrix except in the + submatrix Q(ilo+1:ihi,ilo+1:ihi). + If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and + ILO = 1 and IHI = 0, if M = 0; + if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and + ILO = 1 and IHI = 0, if N = 0. + + [in] A + + A is COMPLEX*16 array, dimension + (LDA,M) if SIDE = 'L' + (LDA,N) if SIDE = 'R' + The vectors which define the elementary reflectors, as + returned by ZGEHRD. + + [in] LDA + + LDA is INTEGER + The leading dimension of the array A. + LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. + + [in] TAU + + TAU is COMPLEX*16 array, dimension + (M-1) if SIDE = 'L' + (N-1) if SIDE = 'R' + TAU(i) must contain the scalar factor of the elementary + reflector H(i), as returned by ZGEHRD. + + [in,out] C + + C is COMPLEX*16 array, dimension (LDC,N) + On entry, the M-by-N matrix C. + On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. + + [in] LDC + + LDC is INTEGER + The leading dimension of the array C. LDC >= max(1,M). + + [out] WORK + + WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) + On exit, if INFO = 0, WORK(1) returns the optimal LWORK. + + [in] LWORK + + LWORK is INTEGER + The dimension of the array WORK. + If SIDE = 'L', LWORK >= max(1,N); + if SIDE = 'R', LWORK >= max(1,M). + For optimum performance LWORK >= N*NB if SIDE = 'L', and + LWORK >= M*NB if SIDE = 'R', where NB is the optimal + blocksize. + + If LWORK = -1, then a workspace query is assumed; the routine + only calculates the optimal size of the WORK array, returns + this value as the first entry of the WORK array, and no error + message related to LWORK is issued by XERBLA. + + [out] INFO + + INFO is INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, + $ LDC, WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL LEFT, LQUERY + INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZUNMQR +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NH = IHI - ILO + LEFT = LSAME( SIDE, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) + $ THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN + INFO = -5 + ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -13 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( LEFT ) THEN + NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, NH, N, NH, -1 ) + ELSE + NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, NH, NH, -1 ) + END IF + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNMHR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( LEFT ) THEN + MI = NH + NI = N + I1 = ILO + 1 + I2 = 1 + ELSE + MI = M + NI = NH + I1 = 1 + I2 = ILO + 1 + END IF +* + CALL ZUNMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA, + $ TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO ) +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of ZUNMHR +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zunmhr} + +\end{chunk} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zunmqr LAPACK} +%\pagehead{zunmqr}{zunmqr} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +\begin{chunk}{zunmqr.input} +)set break resume +)sys rm -f zunmqr.output +)spool zunmqr.output +)set message test on +)set message auto off +)clear all + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{zunmqr.help} +==================================================================== +zunmqr examples +==================================================================== + +==================================================================== +Man Page Details +==================================================================== + + Online html documentation available at + http://www.netlib.org/lapack/explore-html/ + + Definition: + =========== + + SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + WORK, LWORK, INFO ) + + .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N + .. + .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) + .. + + + Purpose: + ============= + + ZUNMQR overwrites the general complex M-by-N matrix C with + + SIDE = 'L' SIDE = 'R' + TRANS = 'N': Q * C C * Q + TRANS = 'C': Q**H * C C * Q**H + + where Q is a complex unitary matrix defined as the product of k + elementary reflectors + + Q = H(1) H(2) . . . H(k) + + as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N + if SIDE = 'R'. + + Arguments: + ========== + + [in] SIDE + + SIDE is CHARACTER*1 + = 'L': apply Q or Q**H from the Left; + = 'R': apply Q or Q**H from the Right. + + [in] TRANS + + TRANS is CHARACTER*1 + = 'N': No transpose, apply Q; + = 'C': Conjugate transpose, apply Q**H. + + [in] M + + M is INTEGER + The number of rows of the matrix C. M >= 0. + + [in] N + + N is INTEGER + The number of columns of the matrix C. N >= 0. + + [in] K + + K is INTEGER + The number of elementary reflectors whose product defines + the matrix Q. + If SIDE = 'L', M >= K >= 0; + if SIDE = 'R', N >= K >= 0. + + [in] A + + A is COMPLEX*16 array, dimension (LDA,K) + The i-th column must contain the vector which defines the + elementary reflector H(i), for i = 1,2,...,k, as returned by + ZGEQRF in the first k columns of its array argument A. + A is modified by the routine but restored on exit. + + [in] LDA + + LDA is INTEGER + The leading dimension of the array A. + If SIDE = 'L', LDA >= max(1,M); + if SIDE = 'R', LDA >= max(1,N). + + [in] TAU + + TAU is COMPLEX*16 array, dimension (K) + TAU(i) must contain the scalar factor of the elementary + reflector H(i), as returned by ZGEQRF. + + [in,out] C + + C is COMPLEX*16 array, dimension (LDC,N) + On entry, the M-by-N matrix C. + On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. + + [in] LDC + + LDC is INTEGER + The leading dimension of the array C. LDC >= max(1,M). + + [out] WORK + + WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) + On exit, if INFO = 0, WORK(1) returns the optimal LWORK. + + [in] LWORK + + LWORK is INTEGER + The dimension of the array WORK. + If SIDE = 'L', LWORK >= max(1,N); + if SIDE = 'R', LWORK >= max(1,M). + For optimum performance LWORK >= N*NB if SIDE = 'L', and + LWORK >= M*NB if SIDE = 'R', where NB is the optimal + blocksize. + + If LWORK = -1, then a workspace query is assumed; the routine + only calculates the optimal size of the WORK array, returns + this value as the first entry of the WORK array, and no error + message related to LWORK is issued by XERBLA. + + [out] INFO + + INFO is INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value + + Authors: + ======== + + Univ. of Tennessee + Univ. of California Berkeley + Univ. of Colorado Denver + NAG Ltd. + + November 2011 + +\end{chunk} + +\begin{verbatim} +* ===================================================================== + SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK computational routine (version 3.4.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2011 +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, LQUERY, NOTRAN + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, + $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW +* .. +* .. Local Arrays .. + COMPLEX*16 T( LDT, NBMAX ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2R +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + LQUERY = ( LWORK.EQ.-1 ) +* +* NQ is the order of Q and NW is the minimum dimension of WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN + INFO = -12 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. NB may be at most NBMAX, where NBMAX +* is used to define the local array T. +* + NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + LWKOPT = MAX( 1, NW )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNMQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* Use unblocked code +* + CALL ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, + $ IINFO ) + ELSE +* +* Use blocked code +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL ZLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), + $ LDA, TAU( I ), T, LDT ) + IF( LEFT ) THEN +* +* H or H**H is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H or H**H is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H or H**H +* + CALL ZLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, + $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, + $ WORK, LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of ZUNMQR +* + END + +\end{verbatim} + +\begin{chunk}{LAPACK zunmqr} + +\end{chunk} + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{LAPACK tests} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\begin{verbatim} +;;; +;;; Simple tests for selected LAPACK routines. +;;; +;;; $Id$ +;;; + +(in-package "LAPACK") + +;; Convert the eigenvalues returned by DGEEV into an array +(defun make-eigval (wr wi) + (let ((e-val (make-array (length wr)))) + (map-into e-val #'(lambda (r i) + ;; Do we really want to do this? Should we + ;; just make all of the eigenvalues complex? + (if (zerop i) + r + (complex r i))) + wr wi) + e-val)) + +;; Convert the eigenvalues returned by DGEEV into a more typical +;; matrix form. +(defun make-eigvec (n vr wi) + (let ((evec (make-array (list n n)))) + (do ((col 0 (incf col)) + (posn 0)) + ((>= col n)) + (cond ((zerop (aref wi col)) + (dotimes (row n) + (setf (aref evec row col) (aref vr posn)) + (incf posn))) + (t + (dotimes (row n) + (let* ((next-posn (+ posn n)) + (val+ (complex (aref vr posn) (aref vr next-posn))) + (val- (conjugate val+))) + (setf (aref evec row col) val+) + (setf (aref evec row (1+ col)) val-) + (incf posn))) + ;; Skip over the next column, which we've already used + (incf col) + (incf posn n)))) + evec)) + +;; Expected results from +;; http://www.nag.co.uk/lapack-ex/examples/results/dgeev-ex.r +;; +;; DGEEV Example Program Results +;; +;; Eigenvalue( 1) = 7.9948E-01 +;; +;; Eigenvector( 1) +;; -6.5509E-01 +;; -5.2363E-01 +;; 5.3622E-01 +;; -9.5607E-02 +;; +;; Eigenvalue( 2) = (-9.9412E-02, 4.0079E-01) +;; +;; Eigenvector( 2) +;; (-1.9330E-01, 2.5463E-01) +;; ( 2.5186E-01,-5.2240E-01) +;; ( 9.7182E-02,-3.0838E-01) +;; ( 6.7595E-01, 0.0000E+00) +;; +;; Eigenvalue( 3) = (-9.9412E-02,-4.0079E-01) +;; +;; Eigenvector( 3) +;; (-1.9330E-01,-2.5463E-01) +;; ( 2.5186E-01, 5.2240E-01) +;; ( 9.7182E-02, 3.0838E-01) +;; ( 6.7595E-01,-0.0000E+00) +;; +;; Eigenvalue( 4) = -1.0066E-01 +;; +;; Eigenvector( 4) +;; 1.2533E-01 +;; 3.3202E-01 +;; 5.9384E-01 +;; 7.2209E-01 +;; +(defun print-dgeev-results (e-val e-vec) + (format t "~2%DGEEV Example Program Results~%") + (let ((n (length e-val))) + (dotimes (k n) + (format t "Eigenvalue(~D) = ~A~%" k (aref e-val k)) + (format t "~%Eigenvector(~D)~%" k) + (dotimes (row n) + (format t "~A~%" (aref e-vec row k))) + (terpri)))) + +(defun check-eigen-val-vec (n e-val e-vec true-val true-vec &key (tol 1d-14)) + (flet ((relerr-ok (est true) + (let* ((re (/ (abs (- est true)) + (abs true))) + (ok (<= re tol))) + ;; Return NIL if it's ok. Otherwise return a list to + ;; indicate what failed. + (unless ok + (format t "est = ~S~%true = ~S~% rel = ~S~%" + est true re) + (list est true re))))) + (or (relerr-ok (aref e-val n) true-val) + (dotimes (k n t) + (let ((res (relerr-ok (aref e-vec k n) (aref true-vec k)))) + (when res + (return res))))))) + +;; DGEEV example based on the example from +;; http://www.nag.co.uk/lapack-ex/node87.html +(defun test-dgeev () + ;; The matrix is + ;; + ;; 0.35 0.45 -0.14 -0.17 + ;; 0.09 0.07 -0.54 0.35 + ;; -0.44 -0.33 -0.03 0.17 + ;; 0.25 -0.32 -0.13 0.11 + ;; + ;; Recall that Fortran arrays are column-major order! + (let* ((n 4) + (a-mat (make-array (* n n) :element-type 'double-float + :initial-contents '(0.35d0 0.09d0 -0.44d0 0.25d0 + 0.45d0 0.07d0 -0.33d0 -0.32d0 + -0.14d0 -0.54d0 -0.03d0 -0.13d0 + -0.17d0 0.35d0 0.17d0 0.11d0))) + (wr (make-array n :element-type 'double-float)) + (wi (make-array n :element-type 'double-float)) + (vl (make-array 0 :element-type 'double-float)) + (vr (make-array (* n n) :element-type 'double-float)) + (lwork 660) + (work (make-array lwork :element-type 'double-float))) + (multiple-value-bind (z-jobvl z-jobvr z-n z-a z-lda z-wr z-wi z-vl z-ldvl + z-vr z-ldvr z-work z-lwork info) + (dgeev "N" "V" n a-mat n wr wi vl n vr n work lwork 0) + (declare (ignore z-jobvl z-jobvr z-n z-a z-lda z-wr z-wi z-vl z-ldvl z-vr + z-ldvr z-work z-lwork)) + (let ((e-val (make-eigval wr wi)) + (e-vec (make-eigvec n vr wi))) + ;; Display solution + (cond ((zerop info) + (print-dgeev-results e-val + e-vec)) + (t + (format t "Failure in DGEEV. INFO = ~D~%" info))) + ;; Display workspace info + (format t "Optimum workspace required = ~D~%" (truncate (aref work 0))) + (format t "Workspace provided = ~D~%" lwork) + + (values e-val e-vec))))) + +(rt:deftest dgeev.1 + (multiple-value-bind (e-val e-vec) + (test-dgeev) + (list (check-eigen-val-vec 0 e-val e-vec + 0.799482122586210d0 + #(-0.6550887675124076d0 + -0.5236294609021240d0 + 0.5362184613722345d0 + -0.0956067782012298d0)) + (check-eigen-val-vec 1 e-val e-vec + #c(-0.0994124532950747d0 0.4007924719897546d0) + #(#c(-0.193301548264222d0 0.254631571927584d0) + #c(0.251856531726740d0 -0.522404734711629d0) + #c(0.097182458443282d0 -0.308383755897228d0) + #c(0.675954054254748 0d0))) + (check-eigen-val-vec 2 e-val e-vec + #c(-0.0994124532950747d0 -0.4007924719897546d0) + #(#c(-0.193301548264222d0 -0.254631571927584d0) + #c(0.251856531726740d0 0.522404734711629d0) + #c(0.097182458443282d0 0.308383755897228d0) + #c(0.675954054254748 0d0))) + (check-eigen-val-vec 3 e-val e-vec + -0.100657215996059d0 + #(0.125332697230903d0 + 0.332022215571751d0 + 0.593837759557331d0 + 0.722087029862455d0 + -0.6550887675124076d0)))) + (t t t t)) + +;; Expected results http://www.nag.co.uk/lapack-ex/examples/results/dgeevx-ex.r +;; +;; DGEEVX Example Program Results +;; +;; Eigenvalue( 1) = 7.9948E-01 +;; +;; Reciprocal condition number = 9.9E-01 +;; Error bound = 1.3E-16 +;; +;; Eigenvector( 1) +;; -6.5509E-01 +;; -5.2363E-01 +;; 5.3622E-01 +;; -9.5607E-02 +;; +;; Reciprocal condition number = 8.2E-01 +;; Error bound = 1.6E-16 +;; +;; Eigenvalue( 2) = (-9.9412E-02, 4.0079E-01) +;; +;; Reciprocal condition number = 7.0E-01 +;; Error bound = 1.8E-16 +;; +;; Eigenvector( 2) +;; (-1.9330E-01, 2.5463E-01) +;; ( 2.5186E-01,-5.2240E-01) +;; ( 9.7182E-02,-3.0838E-01) +;; ( 6.7595E-01, 0.0000E+00) +;; +;; Reciprocal condition number = 4.0E-01 +;; Error bound = 3.3E-16 +;; +;; Eigenvalue( 3) = (-9.9412E-02,-4.0079E-01) +;; +;; Reciprocal condition number = 7.0E-01 +;; Error bound = 1.8E-16 +;; +;; Eigenvector( 3) +;; (-1.9330E-01,-2.5463E-01) +;; ( 2.5186E-01, 5.2240E-01) +;; ( 9.7182E-02, 3.0838E-01) +;; ( 6.7595E-01,-0.0000E+00) +;; +;; Reciprocal condition number = 4.0E-01 +;; Error bound = 3.3E-16 +;; +;; Eigenvalue( 4) = -1.0066E-01 +;; +;; Reciprocal condition number = 5.7E-01 +;; Error bound = 2.3E-16 +;; +;; Eigenvector( 4) +;; 1.2533E-01 +;; 3.3202E-01 +;; 5.9384E-01 +;; 7.2209E-01 +;; +;; Reciprocal condition number = 3.1E-01 +;; Error bound = 4.2E-16 +;; +(defun print-dgeevx-results (tol e-val e-vec rconde rcondv) + (format t "~2%DGEEVX Example Program Results~%") + (let ((n (length e-val))) + (dotimes (k n) + (format t "Eigenvalue(~D) = ~A~%" k (aref e-val k)) + (let ((rcnd (aref rconde k))) + (format t "Reciprocal condition number = ~A~%" rcnd) + (if (plusp rcnd) + (format t "Error bound = ~A~%" (/ tol rcnd)) + (format t "Error bound is infinite~%"))) + + (format t "~%Eigenvector(~D)~%" k) + (dotimes (row n) + (format t "~A~%" (aref e-vec row k))) + (let ((rcnd (aref rcondv k))) + (format t "Reciprocal condition number = ~A~%" rcnd) + (if (plusp rcnd) + (format t "Error bound = ~A~%" (/ tol rcnd)) + (format t "Error bound is infinity~%"))) + (terpri)))) + +(defun test-dgeevx () + (let* ((n 4) + (a-mat (make-array (* n n) :element-type 'double-float + :initial-contents '(0.35d0 0.09d0 -0.44d0 0.25d0 + 0.45d0 0.07d0 -0.33d0 -0.32d0 + -0.14d0 -0.54d0 -0.03d0 -0.13d0 + -0.17d0 0.35d0 0.17d0 0.11d0))) + (wr (make-array n :element-type 'double-float)) + (wi (make-array n :element-type 'double-float)) + (vl (make-array (* n n) :element-type 'double-float)) + (vr (make-array (* n n) :element-type 'double-float)) + (scale (make-array n :element-type 'double-float)) + (rconde (make-array n :element-type 'double-float)) + (rcondv (make-array n :element-type 'double-float)) + (lwork 660) + (work (make-array lwork :element-type 'double-float)) + (iwork (make-array (- (* n 2) 2) :element-type 'f2cl-lib::integer4))) + (multiple-value-bind (z-balanc z-jobvl z-jobvr z-sense z-n z-a z-lda z-wr + z-wi z-vl z-ldvl z-vr z-ldvr ilo ihi z-scale abnrm + z-rconde z-rcondv z-work z-lwork z-iwork info) + (dgeevx "Balance" "Vectors (left)" "Vectors (right)" + "Both reciprocal condition numbers" + n a-mat n wr wi vl n vr n 0 0 scale 0d0 rconde rcondv + work lwork iwork 0) + (declare (ignore z-balanc z-jobvl z-jobvr z-sense z-n z-a z-lda z-wr + z-wi z-vl z-ldvl z-vr z-ldvr z-scale z-rconde z-rcondv + z-work z-lwork z-iwork)) + ;; Display solution + (cond ((zerop info) + (let* ((eps (dlamch "Eps")) + (tol (* eps abnrm))) + (print-dgeevx-results tol + (make-eigval wr wi) + (make-eigvec n vr wi) + rconde rcondv))) + (t + (format t "Failure in DGEEV. INFO = ~D~%" info))) + ;; Display workspace info + (format t "Optimum workspace required = ~D~%" (truncate (aref work 0))) + (format t "Workspace provided = ~D~%" lwork)))) + +;; Expected results (from +;; http://www.nag.co.uk/lapack-ex/examples/results/dgesv-ex.r) +;; Solution +;; 1.0000 -1.0000 3.0000 -5.0000 +;; +;; Details of factorization +;; 1 2 3 4 +;; 1 5.2500 -2.9500 -0.9500 -3.8000 +;; 2 0.3429 3.8914 2.3757 0.4129 +;; 3 0.3010 -0.4631 -1.5139 0.2948 +;; 4 -0.2114 -0.3299 0.0047 0.1314 +;; +;; Pivot indices +;; 2 2 3 4 +;; +(defun print-dgesv-results (n a b ipiv) + (format t "~2%DGESV Example Program Results~%") + (format t "Solution~%") + (dotimes (k n) + (format t "~21,14e " (aref b k))) + (format t "~&Details of factorization~%") + (dotimes (r n) + (dotimes (c n) + (format t "~21,14e" (aref a (+ r (* c n))))) + (terpri)) + (format t "Pivot indices~%") + (dotimes (k n) + (format t " ~d" (aref ipiv k))) + (terpri)) + +(defun test-dgesv () + ;; + ;; Matrix A: + ;; 1.80 2.88 2.05 -0.89 + ;; 5.25 -2.95 -0.95 -3.80 + ;; 1.58 -2.69 -2.90 -1.04 + ;; -1.11 -0.66 -0.59 0.80 + ;; + ;; RHS: + ;; 9.52 24.35 0.77 -6.22 + (let* ((n 4) + (a-mat (make-array (* n n) :element-type 'double-float + :initial-contents '(1.80d0 5.25d0 1.58d0 -1.11d0 + 2.88d0 -2.95d0 -2.69d0 -0.66d0 + 2.05d0 -0.95d0 -2.90d0 -0.59d0 + -0.89d0 -3.80d0 -1.04d0 0.8d0))) + (b (make-array n :element-type 'double-float + :initial-contents '(9.52d0 24.35d0 0.77d0 -6.22d0))) + (ipiv (make-array n :element-type 'f2cl-lib:integer4))) + (multiple-value-bind (z-n z-nrhs z-a z-lda z-ipiv z-b z-ldb info) + (dgesv n 1 a-mat n ipiv b n 0) + (declare (ignore z-n z-nrhs z-a z-lda z-ipiv z-b z-ldb)) + ;; Display solution + (cond ((zerop info) + (print-dgesv-results n a-mat b ipiv)) + (t + (format t "The (~D, ~D) element of the factor U is zero~%" + info info)))))) + +;; Expected results (from ) +;; +;; It seems, however, that the result from that page are wrong. At +;; least they seem wrong when I run the actual test program. The main +;; difference is that the singular vectors have the signs of some +;; entries wrong. +;; +;; The result below is what the test program actually produces. + +;; DGESDD Example Program Results +;; +;; Singular values +;; 9.9966 3.6831 1.3569 0.5000 +;; Left singular vectors +;; 1 2 3 4 +;; 1 -0.1921 0.8030 -0.0041 0.5642 +;; 2 0.8794 0.3926 0.0752 -0.2587 +;; 3 -0.2140 0.2980 -0.7827 -0.5027 +;; 4 0.3795 -0.3351 -0.6178 0.6017 +;; +;; Right singular vectors by row (first m rows of V**T) +;; 1 2 3 4 5 6 +;; 1 -0.2774 -0.2020 -0.2918 0.0938 0.4213 -0.7816 +;; 2 0.6003 0.0301 -0.3348 0.3699 -0.5266 -0.3353 +;; 3 0.1277 -0.2805 -0.6453 -0.6781 -0.0413 0.1645 +;; 4 -0.1323 -0.7034 -0.1906 0.5399 0.0575 0.3957 +;; +;; Error estimate for the singular values +;; 1.1E-15 +;; +;; Error estimates for the left singular vectors +;; 1.8E-16 4.8E-16 1.3E-15 1.3E-15 +;; +;; Error estimates for the right singular vectors +;; 1.8E-16 4.8E-16 1.3E-15 2.2E-15 +;; +(defun print-dgesdd-results (m n s u a) + (format t "~2%DGESDD Example Program Results~%") + (format t "Singular values~%") + (dotimes (k m) + (format t "~20,14e" (aref s k))) + (format t "~2%Left singular vectors~%") + (dotimes (r m) + (dotimes (c m) + (format t "~16,7e" (aref u (+ r (* c m))))) + (terpri)) + (format t "~%Right singular vectors (first m rows of V**T)~%") + (dotimes (r m) + (dotimes (c n) + (format t "~16,7e" (aref a (+ r (* c m))))) + (terpri)) + ;; Compute error estimates for the singular vectors + (let ((serrbd (* (aref s 0) (dlamch "Eps"))) + (rcondu (make-array m :element-type 'double-float)) + (rcondv (make-array m :element-type 'double-float)) + (uerrbd (make-array m :element-type 'double-float)) + (verrbd (make-array m :element-type 'double-float))) + (ddisna "Left" m n s rcondu 0) + (ddisna "Right" m n s rcondv 0) + (dotimes (k m) + (setf (aref uerrbd k) (/ serrbd (aref rcondu k))) + (setf (aref verrbd k) (/ serrbd (aref rcondv k)))) + (format t "Error estimate for the singular values~%") + (format t "~20,15g~%" serrbd) + (format t "~%~%Error estimates for the left singular values~%") + (format t "~{~15,4e~^ ~}~%" (coerce uerrbd 'list)) + (format t "~%~%Error estimates for the right singular values~%") + (format t "~{~15,4e~^ ~}~%" (coerce verrbd 'list)))) + +(defun test-dgesdd () + ;; + ;; Matrix A: + ;; 2.27 0.28 -0.48 1.07 -2.35 0.62 + ;; -1.54 -1.67 -3.09 1.22 2.93 -7.39 + ;; 1.15 0.94 0.99 0.79 -1.45 1.03 + ;; -1.94 -0.78 -0.21 0.63 2.30 -2.57 + (let* ((m 4) ; rows + (n 6) ; cols + (a-mat (make-array (* m n) :element-type 'double-float + :initial-contents '(2.27d0 -1.54d0 1.15d0 -1.94d0 + 0.28d0 -1.67d0 0.94d0 -0.78d0 + -0.48d0 -3.09d0 0.99d0 -0.21d0 + 1.07d0 1.22d0 0.79d0 0.63d0 + -2.35d0 2.93d0 -1.45d0 2.30d0 + 0.62d0 -7.39d0 1.03d0 -2.57d0))) + (s (make-array (min m n) :element-type 'double-float)) + (u (make-array (* m (min m n)):element-type 'double-float)) + (vt (make-array (* n n) :element-type 'double-float)) + (lwork 1000) + (work (make-array lwork :element-type 'double-float)) + (iwork (make-array (* 8 (min m n)) :element-type 'f2cl-lib:integer4))) + (multiple-value-bind (z-jobz z-m z-n z-a z-lda z-s z-u z-ldu z-vt z-ldvt + z-work z-lwork z-iwork info) + (dgesdd "Overwrite A by transpose(V)" + m n a-mat m s u m vt n work lwork iwork 0) + (declare (ignore z-jobz z-m z-n z-a z-lda z-s z-u z-ldu z-vt z-ldvt + z-work z-lwork z-iwork )) + ;; Display solution + (cond ((zerop info) + (print-dgesdd-results m n s u a-mat)) + (t + (format t "Failure in DGESDD. Info = ~D~%" info))) + (format t "Optimum workspace required = ~D~%" (truncate (aref work 0))) + (format t "Workspace provided = ~D~%" lwork)))) + +;; Expected results (from +;; http://www.nag.co.uk/lapack-ex/examples/results/dgesvd-ex.r) +;; DGESVD Example Program Results +;; +;; Singular values +;; 9.9966 3.6831 1.3569 0.5000 +;; Left singular vectors (first n columns of U) +;; 1 2 3 4 +;; 1 -0.2774 -0.6003 -0.1277 0.1323 +;; 2 -0.2020 -0.0301 0.2805 0.7034 +;; 3 -0.2918 0.3348 0.6453 0.1906 +;; 4 0.0938 -0.3699 0.6781 -0.5399 +;; 5 0.4213 0.5266 0.0413 -0.0575 +;; 6 -0.7816 0.3353 -0.1645 -0.3957 +;; +;; Right singular vectors by row (V**T) +;; 1 2 3 4 +;; 1 -0.1921 0.8794 -0.2140 0.3795 +;; 2 -0.8030 -0.3926 -0.2980 0.3351 +;; 3 0.0041 -0.0752 0.7827 0.6178 +;; 4 -0.5642 0.2587 0.5027 -0.6017 +;; +;; Error estimate for the singular values +;; 1.1E-15 +;; +;; Error estimates for the left singular vectors +;; 1.8E-16 4.8E-16 1.3E-15 2.2E-15 +;; +;; Error estimates for the right singular vectors +;; 1.8E-16 4.8E-16 1.3E-15 1.3E-15 +;; +(defun print-dgesvd-results (m n s vt a) + (format t "~2%DGESVD Example Program Results~%") + (format t "Singular values~%") + (dotimes (k n) + (format t "~20,14e" (aref s k))) + (format t "~2%Left singular vectors~%") + (dotimes (r m) + (dotimes (c n) + (format t "~16,7e" (aref a (+ r (* c m))))) + (terpri)) + (format t "~%Right singular vectors (first m rows of V**T)~%") + (dotimes (r n) + (dotimes (c n) + (format t "~16,7e" (aref vt (+ r (* c n))))) + (terpri)) + ;; Compute error estimates for the singular vectors + (let ((serrbd (* (aref s 0) (dlamch "Eps"))) + (rcondu (make-array n :element-type 'double-float)) + (rcondv (make-array n :element-type 'double-float)) + (uerrbd (make-array n :element-type 'double-float)) + (verrbd (make-array n :element-type 'double-float))) + (ddisna "Left" m n s rcondu 0) + (ddisna "Right" m n s rcondv 0) + (dotimes (k n) + (setf (aref uerrbd k) (/ serrbd (aref rcondu k))) + (setf (aref verrbd k) (/ serrbd (aref rcondv k)))) + (format t "Error estimate for the singular values~%") + (format t "~20,15g~%" serrbd) + (format t "~%~%Error estimates for the left singular values~%") + (format t "~{~15,4e~^ ~}~%" (coerce uerrbd 'list)) + (format t "~%~%Error estimates for the right singular values~%") + (format t "~{~15,4e~^ ~}~%" (coerce verrbd 'list)))) + +(defun test-dgesvd () + ;; + ;; Matrix A: + ;; 2.27 -1.54 1.15 -1.94 + ;; 0.28 -1.67 0.94 -0.78 + ;; -0.48 -3.09 0.99 -0.21 + ;; 1.07 1.22 0.79 0.63 + ;; -2.35 2.93 -1.45 2.30 + ;; 0.62 -7.39 1.03 -2.57 + (let* ((m 6) ; rows + (n 4) ; cols + (a-mat (make-array (* m n) :element-type 'double-float + :initial-contents '(2.27d0 0.28d0 -0.48d0 1.07d0 -2.35d0 0.62d0 + -1.54d0 -1.67d0 -3.09d0 1.22d0 2.93d0 -7.39d0 + 1.15d0 0.94d0 0.99d0 0.79d0 -1.45d0 1.03d0 + -1.94d0 -0.78d0 -0.21d0 0.63d0 2.30d0 -2.57d0))) + (s (make-array (min m n) :element-type 'double-float)) + (u (make-array (* m (min m n)):element-type 'double-float)) + (vt (make-array (* n n) :element-type 'double-float)) + (lwork (+ 10 (* 4 8) + (* 64 (+ 10 8)))) + (work (make-array lwork :element-type 'double-float))) + (multiple-value-bind (z-jobz z-jobvt z-m z-n z-a z-lda z-s z-u z-ldu z-vt + z-ldvt z-work z-lwork info) + (dgesvd "Overwrite A by U" "Singular vectors (V)" + m n a-mat m s u m vt n work lwork 0) + (declare (ignore z-jobz z-jobvt z-m z-n z-a z-lda z-s z-u z-ldu z-vt + z-ldvt z-work z-lwork)) + ;; Display solution + (cond ((zerop info) + (print-dgesvd-results m n s vt a-mat)) + (t + (format t "Failure in DGESDD. Info = ~D~%" info))) + (format t "Optimum workspace required = ~D~%" (truncate (aref work 0))) + (format t "Workspace provided = ~D~%" lwork)))) + +(defun make-complex-eigvec (n vr) + (make-array (list n n) + :displaced-to vr + :element-type (array-element-type vr))) + +(defun print-zgeev-results (e-val e-vec) + (format t "~2%ZGEEV Example Program Results~%") + (let ((n (length e-val))) + (dotimes (k n) + (format t "Eigenvalue(~D) = ~A~%" k (aref e-val k)) + (format t "~%Eigenvector(~D)~%" k) + (dotimes (row n) + (format t "~A~%" (aref e-vec row k))) + (terpri)))) + +(defun test-zgeev () + ;; The matrix is + ;; + ;; #c(-3.97, -5.04) #c(-4.11, 3.70) #c(-0.34, 1.01) #c( 1.29, -0.86) + ;; #c( 0.34, -1.50) #c( 1.52, -0.43) #c( 1.88, -5.38) #c( 3.36, 0.65) + ;; #c( 3.31, -3.85) #c( 2.50, 3.45) #c( 0.88, -1.08) #c( 0.64, -1.48) + ;; #c(-1.10, 0.82) #c( 1.81, -1.59) #c( 3.25, 1.33) #c( 1.57, -3.44) + ;; + ;; Recall that Fortran arrays are column-major order! + (let* ((n 4) + (a-mat (make-array (* n n) + :element-type '(complex double-float) + :initial-contents '(#c(-3.97d0 -5.04d0) + #c( 0.34d0 -1.50d0) + #c( 3.31d0 -3.85d0) + #c(-1.10d0 0.82d0) + #c(-4.11d0 3.70d0) + #c( 1.52d0 -0.43d0) + #c( 2.50d0 3.45d0) + #c( 1.81d0 -1.59d0) + #c(-0.34d0 1.01d0) + #c( 1.88d0 -5.38d0) + #c( 0.88d0 -1.08d0) + #c( 3.25d0 1.33d0) + #c( 1.29d0 -0.86d0) + #c( 3.36d0 0.65d0) + #c( 0.64d0 -1.48d0) + #c( 1.57d0 -3.44d0)))) + (lwork 660) + (w (make-array n :element-type '(complex double-float))) + (rw (make-array lwork :element-type 'double-float)) + (vl (make-array 0 :element-type '(complex double-float))) + (vr (make-array (* n n) :element-type '(complex double-float))) + (work (make-array lwork :element-type '(complex double-float)))) + (multiple-value-bind (z-jobvl z-jobvr z-n z-a z-lda z-w z-vl z-ldvl z-vr + z-ldvr z-work z-lwork z-rwork info) + (zgeev "N" "V" n a-mat n w vl n vr n work lwork rw 0) + (declare (ignore z-jobvl z-jobvr z-n z-a z-lda z-w z-vl z-ldvl z-vr + z-ldvr z-work z-lwork z-rwork)) + ;; Display solution + (cond ((zerop info) + (print-zgeev-results w + (make-complex-eigvec n vr))) + (t + (format t "Failure in DGEEV. INFO = ~D~%" info))) + ;; Display workspace info + (format t "Optimum workspace required = ~D~%" + (truncate (realpart (aref work 0)))) + (format t "Workspace provided = ~D~%" lwork)))) + +(defun do-all-lapack-tests () + (test-dgeev) + (test-dgeevx) + (test-dgesv) + (test-dgesdd) + (test-dgesvd) + (test-zgeev)) + +;;; $Log$ +;;; Revision 1.11 2006/12/01 04:29:29 rtoy +;;; Create packages for BLAS and LAPACK routines. +;;; +;;; blas.system: +;;; o Converted files are in the BLAS package. +;;; o Add blas-package defsystem to load the package definition. +;;; +;;; lapack.system: +;;; o Converted files are in the LAPACK package. +;;; o Add lapack-package defsystem to load the package definition. +;;; +;;; lapack/lapack-tests.lisp: +;;; o Tests are in the LAPACK package +;;; +;;; Revision 1.10 2006/11/28 15:49:01 rtoy +;;; Print out short title for each test. +;;; +;;; Revision 1.9 2006/11/27 22:22:23 rtoy +;;; Add expected results. +;;; +;;; Revision 1.8 2006/11/27 20:04:33 rtoy +;;; Add DGESVD and update files and tests appropriately. +;;; +;;; Revision 1.7 2006/11/27 15:23:29 rtoy +;;; Add function to run all the tests. +;;; +;;; Revision 1.6 2006/11/26 23:26:47 rtoy +;;; packages/lapack.system: +;;; o Add DGESDD and dependencies +;;; o Add DDISNA to compute condition number of singular vectors +;;; +;;; packages/lapack/.cvsignore: +;;; o Ignore new generated Lisp files. +;;; +;;; packages/lapack/lapack-tests.lisp: +;;; o Add test for DGESDD +;;; +;;; Revision 1.5 2006/11/26 14:26:42 rtoy +;;; Add expected results for DGESV. +;;; +;;; Revision 1.4 2006/11/26 14:24:46 rtoy +;;; packages/lapack.system: +;;; o DGESV and dependencies +;;; +;;; packages/.cvsignore: +;;; o Ignore generated dgesv.lisp and dependencies +;;; +;;; packages/lapack/lapack-tests.lisp: +;;; o Test routine for DGESV +;;; +;;; Revision 1.3 2006/11/26 05:31:16 rtoy +;;; packages/lapack.system: +;;; o Add DGEEVX and dependencies +;;; +;;; packages/lapack/lapack-tests.lisp: +;;; o Add test for DGEEVX +;;; o Add comments +;;; +;;; packages/lapack/dgeevx.f: +;;; packages/lapack/dlacon.f: +;;; packages/lapack/dlaexc.f: +;;; packages/lapack/dlaqtr.f: +;;; packages/lapack/dlasy2.f: +;;; packages/lapack/dtrexc.f: +;;; packages/lapack/dtrsna.f: +;;; o New files for DGEEVX and dependencies. +;;; +;;; Revision 1.2 2006/11/26 04:53:22 rtoy +;;; Add comments +;;; +;;; Revision 1.1 2006/11/26 04:51:05 rtoy +;;; packages/lapack.system: +;;; o Add defsystem for LAPACK tests +;;; +;;; packages/lapack/lapack-tests.lisp: +;;; o Add simple tests for LAPACK. (Currently only DGEEV). +;;; + +\end{verbatim} + + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Chunk collections} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -75978,6 +121827,7 @@ ARGUMENTS \getchunk{LAPACK dgetrf} \getchunk{LAPACK dgetrs} \getchunk{LAPACK dhseqr} +\getchunk{LAPACK disnan} \getchunk{LAPACK dlabad} \getchunk{LAPACK dlabrd} \getchunk{LAPACK dlacon} @@ -75987,6 +121837,7 @@ ARGUMENTS \getchunk{LAPACK dlaexc} \getchunk{LAPACK dlahqr} \getchunk{LAPACK dlahrd} +\getchunk{LAPACK dlaisnan} \getchunk{LAPACK dlaln2} \getchunk{LAPACK dlamch} \getchunk{LAPACK dlamc1} @@ -76000,6 +121851,7 @@ ARGUMENTS \getchunk{LAPACK dlanst} \getchunk{LAPACK dlanv2} \getchunk{LAPACK dlapy2} +\getchunk{LAPACK dlapy3} \getchunk{LAPACK dlaqtr} \getchunk{LAPACK dlarfb} \getchunk{LAPACK dlarfg} @@ -76050,8 +121902,44 @@ ARGUMENTS \getchunk{LAPACK dtrsna} \getchunk{LAPACK ieeeck} \getchunk{LAPACK ilaenv} +\getchunk{LAPACK ilazlc} +\getchunk{LAPACK ilazlr} +\getchunk{LAPACK zgebak} +\getchunk{LAPACK zgebal} +\getchunk{LAPACK zgeev} +\getchunk{LAPACK zgehd2} +\getchunk{LAPACK zgehrd} +\getchunk{LAPACK zhseqr} +\getchunk{LAPACK zlacgv} +\getchunk{LAPACK zlacpy} +\getchunk{LAPACK zladiv} +\getchunk{LAPACK zlahqr} +\getchunk{LAPACK zlahr2} \getchunk{LAPACK zlange} +\getchunk{LAPACK zlaqr0} +\getchunk{LAPACK zlaqr1} +\getchunk{LAPACK zlaqr2} +\getchunk{LAPACK zlaqr3} +\getchunk{LAPACK zlaqr4} +\getchunk{LAPACK zlaqr5} +\getchunk{LAPACK zlarfb} +\getchunk{LAPACK zlarf} +\getchunk{LAPACK zlarfg} +\getchunk{LAPACK zlarft} +\getchunk{LAPACK zlartg} +\getchunk{LAPACK zlascl} +\getchunk{LAPACK zlaset} \getchunk{LAPACK zlassq} +\getchunk{LAPACK zlatrs} +\getchunk{LAPACK zrot} +\getchunk{LAPACK ztrevc} +\getchunk{LAPACK ztrexc} +\getchunk{LAPACK zung2r} +\getchunk{LAPACK zunghr} +\getchunk{LAPACK zungqr} +\getchunk{LAPACK zunm2r} +\getchunk{LAPACK zunmhr} +\getchunk{LAPACK zunmqr} \end{chunk} \begin{thebibliography}{99} diff --git a/books/bookvol5.pamphlet b/books/bookvol5.pamphlet index cd5b077..b0c5611 100644 --- a/books/bookvol5.pamphlet +++ b/books/bookvol5.pamphlet @@ -103,46 +103,50 @@ of effort. We would like to acknowledge and thank the following people: "Gilbert Baumslag Michael Becker Nelson H. F. Beebe" "Jay Belanger David Bindel Fred Blair" "Vladimir Bondarenko Mark Botch Alexandre Bouyer" -"Peter A. Broadbery Martin Brock Manuel Bronstein" -"Stephen Buchwald Florian Bundschuh Luanne Burns" -"William Burge" +"Karen Braman Peter A. Broadbery Martin Brock" +"Manuel Bronstein Stephen Buchwald Florian Bundschuh" +"Luanne Burns William Burge Ralph Byers" "Quentin Carpent Robert Caviness Bruce Char" -"Ondrej Certik Cheekai Chin David V. Chudnovsky" -"Gregory V. Chudnovsky Mark Clements James Cloos" -"Josh Cohen Christophe Conil Don Coppersmith" -"George Corliss Robert Corless Gary Cornell" -"Meino Cramer Claire Di Crescenzo David Cyganski" +"Ondrej Certik Tzu-Yi Chen Cheekai Chin" +"David V. Chudnovsky Gregory V. Chudnovsky Mark Clements" +"James Cloos Josh Cohen Christophe Conil" +"Don Coppersmith George Corliss Robert Corless" +"Gary Cornell Meino Cramer Claire Di Crescenzo" +"Jeremy Du Croz David Cyganski" "Nathaniel Daly Timothy Daly Sr. Timothy Daly Jr." -"James H. Davenport Didier Deshommes Michael Dewar" +"James H. Davenport David Day James Demmel" +"Didier Deshommes Michael Dewar Jack Dongarra" "Jean Della Dora Gabriel Dos Reis Claire DiCrescendo" -"Sam Dooley Lionel Ducos Lee Duhem" -"Martin Dunstan Brian Dupee Dominique Duval" +"Sam Dooley Lionel Ducos Iain Duff" +"Lee Duhem Martin Dunstan Brian Dupee" +"Dominique Duval" "Robert Edwards Heow Eide-Goodman Lars Erickson" "Richard Fateman Bertfried Fauser Stuart Feldman" "John Fletcher Brian Ford Albrecht Fortenbacher" "George Frances Constantine Frangos Timothy Freeman" "Korrinn Fu" -"Marc Gaetano Rudiger Gebauer Kathy Gerber" -"Patricia Gianni Samantha Goldrich Holger Gollan" -"Teresa Gomez-Diaz Laureano Gonzalez-Vega Stephen Gortler" -"Johannes Grabmeier Matt Grayson Klaus Ebbe Grue" -"James Griesmer Vladimir Grinberg Oswald Gschnitzer" -"Jocelyn Guidry" +"Marc Gaetano Rudiger Gebauer Van de Geijn" +"Kathy Gerber Patricia Gianni Samantha Goldrich" +"Holger Gollan Teresa Gomez-Diaz Laureano Gonzalez-Vega" +"Stephen Gortler Johannes Grabmeier Matt Grayson" +"Klaus Ebbe Grue James Griesmer Vladimir Grinberg" +"Oswald Gschnitzer Ming Gu Jocelyn Guidry" "Gaetan Hache Steve Hague Satoshi Hamaguchi" -"Mike Hansen Richard Harke Bill Hart" -"Vilya Harvey Martin Hassner Arthur S. Hathaway" -"Dan Hatton Waldek Hebisch Karl Hegbloom" -"Ralf Hemmecke Henderson Antoine Hersen" -"Roger House Gernot Hueber" +"Sven Hammarling Mike Hansen Richard Hanson" +"Richard Harke Bill Hart Vilya Harvey" +"Martin Hassner Arthur S. Hathaway Dan Hatton" +"Waldek Hebisch Karl Hegbloom Ralf Hemmecke" +"Henderson Antoine Hersen Roger House" +"Gernot Hueber" "Pietro Iglio" "Alejandro Jakubi Richard Jenks" -"Kai Kaminski Grant Keady Wilfrid Kendall" -"Tony Kennedy Ted Kosan Paul Kosinski" -"Klaus Kusche Bernhard Kutzler" +"William Kahan Kai Kaminski Grant Keady" +"Wilfrid Kendall Tony Kennedy Ted Kosan" +"Paul Kosinski Klaus Kusche Bernhard Kutzler" "Tim Lahey Larry Lambe Kaj Laurson" -"Franz Lehner Frederic Lehobey Michel Levaud" -"Howard Levy Liu Xiaojun Rudiger Loos" -"Michael Lucks Richard Luczak" +"George L. Legendre Franz Lehner Frederic Lehobey" +"Michel Levaud Howard Levy Ren-Cang Li" +"Rudiger Loos Michael Lucks Richard Luczak" "Camm Maguire Francois Maltey Alasdair McAndrew" "Bob McElrath Michael McGettrick Ian Meikle" "David Mentre Victor S. Miller Gerard Milmeister" @@ -157,18 +161,19 @@ of effort. We would like to acknowledge and thank the following people: "Julian A. Padget Bill Page David Parnas" "Susan Pelzel Michel Petitot Didier Pinchon" "Ayal Pinkus Jose Alfredo Portes" -"Claude Quitte" +"Gregorio Quintana-Orti Claude Quitte" "Arthur C. Ralfs Norman Ramsey Anatoly Raportirenko" "Albert D. Rich Michael Richardson Guilherme Reis" -"Renaud Rioboo Jean Rivlin Nicolas Robidoux" -"Simon Robinson Raymond Rogers Michael Rothstein" -"Martin Rubey" +"Huan Ren Renaud Rioboo Jean Rivlin" +"Nicolas Robidoux Simon Robinson Raymond Rogers" +"Michael Rothstein Martin Rubey" "Philip Santas Alfred Scheerhorn William Schelter" "Gerhard Schneider Martin Schoenert Marshall Schor" "Frithjof Schulze Fritz Schwarz Steven Segletes" -"Nick Simicich William Sit Elena Smirnova" -"Jonathan Steinbach Fabio Stumbo Christine Sundaresan" -"Robert Sutor Moss E. Sweedler Eugene Surowitz" +"V. Sima Nick Simicich William Sit" +"Elena Smirnova Jonathan Steinbach Fabio Stumbo" +"Christine Sundaresan Robert Sutor Moss E. Sweedler" +"Eugene Surowitz" "Max Tegmark T. Doug Telford James Thatcher" "Balbir Thomas Mike Thomas Dylan Thurston" "Steve Toleque Barry Trager Themos T. Tsikas" @@ -176,9 +181,11 @@ of effort. We would like to acknowledge and thank the following people: "Bernhard Wall Stephen Watt Jaap Weel" "Juergen Weiss M. Weller Mark Wegman" "James Wen Thorsten Werther Michael Wester" -"John M. Wiley Berhard Will Clifton J. Williamson" -"Stephen Wilson Shmuel Winograd Robert Wisbauer" -"Sandra Wityak Waldemar Wiwianka Knut Wolf" +"R. Clint Whaley John M. Wiley Berhard Will" +"Clifton J. Williamson Stephen Wilson Shmuel Winograd" +"Robert Wisbauer Sandra Wityak Waldemar Wiwianka" +"Knut Wolf" +"Liu Xiaojun" "Clifford Yapp David Yun" "Vadim Zhytnikov Richard Zippel Evelyn Zoernack" "Bruno Zuercher Dan Zwillinger" diff --git a/books/bookvolbib.bib b/books/bookvolbib.bib new file mode 100644 index 0000000..cb44193 --- /dev/null +++ b/books/bookvolbib.bib @@ -0,0 +1,3317 @@ +%% Created for Timothy Daly at 2012-03-10 06:07:15 -0500 +%% Saved with string encoding Unicode (UTF-8) + +@book{REF-Pea56, + Author = {T. Pearcey}, + Date-Added = {2012-03-10 06:06:24 -0500}, + Date-Modified = {2012-03-10 06:07:06 -0500}, + Publisher = {Cambridge University Press}, + Title = {Table of the Fresnel Integral}, + Year = {1956}} + +@book{REF-Luk269, + Author = {Yudell L. Luke}, + Date-Added = {2012-03-10 05:54:57 -0500}, + Date-Modified = {2012-03-10 06:06:12 -0500}, + Keywords = {ISBN 012459901X}, + Publisher = {Academic Press}, + Series = {Mathematics in Science and Engineering}, + Title = {The Special Functions and their Approximations - V2}, + Volume = {53}, + Year = {1969}} + +@book{REF-Luk169, + Author = {Yudell L. Luke}, + Date-Added = {2012-03-10 05:50:20 -0500}, + Date-Modified = {2012-03-10 06:06:04 -0500}, + Keywords = {ISBN 012459901X}, + Publisher = {Academic Press}, + Series = {Mathematics in Science and Engineering}, + Title = {The Special Functions and their Approximations - V1}, + Volume = {53}, + Year = {1969}} + +@book{REF-Los60, + Author = {Friedrich L\"osch}, + Date-Added = {2012-03-10 05:47:54 -0500}, + Date-Modified = {2012-03-10 05:49:10 -0500}, + Keywords = {QA55.J3 1960}, + Publisher = {McGraw-Hill Book Company}, + Title = {Tables of Higher Functions}, + Year = {1960}} + +@misc{REF-DA98, + Author = {Stephane Dalmas, Olivier Arsac}, + Date-Added = {2012-03-10 05:43:55 -0500}, + Date-Modified = {2012-03-10 05:44:59 -0500}, + Howpublished = {Project SAFIR, INRIA Antipolis}, + Month = {November 25}, + Title = {The INRIA OpenMath Library}, + Year = {1998}} + +@misc{REF-We71, + Author = {Andr\'e Weil}, + Date-Added = {2012-03-10 05:42:53 -0500}, + Date-Modified = {2012-03-10 05:43:47 -0500}, + Howpublished = {Hermann, Paris}, + Title = {Courbes alg\'ebriques et vari\'et\'es}, + Year = {1971}} + +@inproceedings{REF-Yu76, + Address = {New York, NY 10036 USA}, + Author = {David Y. Y. Yun}, + Booktitle = {Symposium on Symbolic and Algebraic Compution}, + Date-Added = {2012-03-10 05:40:42 -0500}, + Date-Modified = {2012-03-10 05:42:08 -0500}, + Editor = {Richard D. Jenks}, + Keywords = {LCCN QS155.7.EA.A15 1976 QA9.58.A11 1976}, + Organization = {Association for Computing Machinery}, + Pages = {26-35}, + Publisher = {ACM Press}, + Title = {On square-free decomposition algorithms}, + Year = {1976}} + +@inproceedings{REF-RF94, + Address = {New York, NY 10036 USA}, + Author = {Dan Richardson, John Fitch}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-10 05:38:35 -0500}, + Date-Modified = {2012-03-10 05:40:07 -0500}, + Keywords = {ISBN 0-89791-638-7 LCCN QA76.95.I59 1994}, + Organization = {Association for Computing Machinery}, + Pages = {285-290}, + Publisher = {ACM Press}, + Title = {The identity problem for elementary functions and constants}, + Year = {1994}} + +@inproceedings{REF-Pra73, + Address = {\verb|hall.org.ua/halls/wizzard/pdf/Vaughn.Pratt.TDOP.pdf|}, + Author = {Vaughan R. Pratt}, + Booktitle = {POPL73 Proceedings of the 1st annual ACM SIGACT-SIGPLAN symposium on Principles of programming languages}, + Date-Added = {2012-03-10 05:36:24 -0500}, + Date-Modified = {2012-03-10 05:37:52 -0500}, + Title = {Top down operator precedence}, + Year = {1973}} + +@inproceedings{REF-HI96, + Author = {M. D. Huang and D. Ierardi}, + Booktitle = {Proceedings 32nd Annual Symposium on Foundations of Computer Sciences}, + Date-Added = {2012-03-10 05:34:10 -0500}, + Date-Modified = {2012-03-10 05:36:12 -0500}, + Organization = {IEEE Computer Society }, + Pages = {678-687}, + Publisher = {IEEE Computer Society Press}, + Title = {Efficient algorithms for Riemann-Roch problem and for addition in the jacobian of a curve}, + Year = {1996}} + +@article{REF-Her1972, + Author = {E. Hermite}, + Date-Added = {2012-03-10 05:32:45 -0500}, + Date-Modified = {2012-03-10 05:33:48 -0500}, + Journal = {Nouvelles Annales de Math\'ematiques}, + Pages = {145-148}, + Title = {Sur L'int\'egration des fractions rationelles}, + Volume = {11}, + Year = {1872}} + +@article{REF-Mal72 + Author = {Malcolm, M. A.}, + Date-Added = {2012-04-22 05:32:45 -0500}, + Date-Modified = {2012-04-22 05:33:48 -0500}, + Journal = {Communcations of the ACM}, + Pages = {949-951}, + Title = {Algorithms to reveal properties of +floating-point arithmetic}, + Volume = {15}, + Year = {1972}} + +@article{REF-GM74 + Author = {Gentleman, W. M. and Marovich S. B.}, + Date-Added = {2012-04-22 05:32:45 -0500}, + Date-Modified = {2012-04-22 05:33:48 -0500}, + Journal = {Communcations of the ACM}, + Pages = {276-277}, + Title = {More on algorithms +that reveal properties of floating point arithmetic units}, + Volume = {17}, + Year = {1974}} + +@article{REF-BBM02a + Author = {K. Braman, R. Byers and R. Mathias}, + Date-Added = {2012-04-22 05:32:45 -0500}, + Date-Modified = {2012-04-22 05:33:48 -0500}, + Journal = {SIAM Journal of Matrix Analysis}, + Pages = {929-947}, + Title = {The Multi-Shift QR +Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 +Performance}, + Volume = {23}, + Year = {2002}} + +@article{REF-BBM02b + Author = {K. Braman, R. Byers and R. Mathias}, + Date-Added = {2012-04-22 05:32:45 -0500}, + Date-Modified = {2012-04-22 05:33:48 -0500}, + Journal = {SIAM Journal of Matrix Analysis}, + Pages = {948-973}, + Title = {The Multi-Shift QR Algorithm Part II: +Aggressive Early Deflation}, + Volume = {23}, + Year = {2002}} + +@article{REF-QG06 + Author = {Gregorio Quintana-Orti and Robert van de Geijn}, + Date-Added = {2012-04-22 05:32:45 -0500}, + Date-Modified = {2012-04-22 05:33:48 -0500}, + Journal = {ACM Transactions on Mathematical Software}, + Pages = {180-194}, + Title = {Improving the performance of reduction to Hessenberg form}, + Volume = {32}, + Number = {2}, + Month = {June}, + Year = {2006}} + +@article{REF-Hig88, + Author = {N. J. Higham}, + Date-Added = {2012-04-22 05:32:45 -0500}, + Date-Modified = {2012-04-22 05:33:48 -0500}, + Journal = {ACM Trans. Math. Soft}, + Pages = {381-396}, + Title = {FORTRAN codes for estimating the one-norm of a +real or complex matrix, with applications to condition estimation}, + Volume = {14}, + Number = {4}, + Month = {December}, + Year = {1988}} + +@inproceedings{REF-Fl09, + Address = {Aston Triangle, Birmingham B4 7 ET, U.K.}, + Author = {John P. Fletcher}, + Booktitle = {Chemical Engineering and Applied Chemistry}, + Date-Added = {2012-03-10 05:30:06 -0500}, + Date-Modified = {2012-03-10 05:32:28 -0500}, + Keywords = {\verb|www.ceac.aston.ac.uk/research/staff/jpf/papers/paper24/index.php|}, + Organization = {Aston University}, + Title = {Clifford Numbers and their inverses calculated using the matrix representation}, + Year = {2009}} + +@inproceedings{REF-Bro91, + Address = {New York, NY 10036 USA}, + Author = {Manuel Bronstein}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-10 05:28:18 -0500}, + Date-Modified = {2012-03-10 05:29:37 -0500}, + Editor = {Stephen M. Watt}, + Keywords = {ISBN 0-89791-437-6 LCCN QA76.95.I59 1991}, + Month = {July 15-17}, + Organization = {Association for Computing Machinery}, + Publisher = {ACM Press}, + Title = {The Risch differential equation on an algebraic curve}, + Year = {1991}} + +@article{REF-Ris70, + Author = {Robert Risch}, + Date-Added = {2012-03-10 05:26:15 -0500}, + Date-Modified = {2012-03-10 05:27:04 -0500}, + Journal = {Transactions of the American Mathematical Society}, + Pages = {605-608}, + Title = {The solution of problem of integration in finite terms}, + Volume = {76}, + Year = {1970}} + +@article{REF-Ris69b, + Author = {Robert Risch}, + Date-Added = {2012-03-10 05:25:04 -0500}, + Date-Modified = {2012-03-10 05:26:08 -0500}, + Journal = {Transactions of the American Mathematical Society}, + Pages = {167-189}, + Title = {The problem of integration in finite terms}, + Volume = {139}, + Year = {1969}} + +@techreport{REF-Ris88, + Author = {Robert Risch}, + Date-Added = {2012-03-10 05:23:40 -0500}, + Date-Modified = {2012-03-10 05:24:46 -0500}, + Institution = {System Development Corporation}, + Number = {SP-2801/002/00}, + Title = {On the integration of elementary functions which are built up using algebraic operations}, + Type = {Research Report}, + Year = {1968}} + +@misc{REF-Ri10, + Author = {Albert D. Rich}, + Date-Added = {2012-03-10 05:22:15 -0500}, + Date-Modified = {2012-03-10 05:22:50 -0500}, + Howpublished = {\verb|www.apmaths.uwo.ca/~arich|}, + Title = {Rule-based Mathematics}} + +@misc{REF-Ra03, + Date-Added = {2012-03-10 05:21:33 -0500}, + Date-Modified = {2012-03-10 05:22:08 -0500}, + Howpublished = {\verb|www.eecs.harvard.edu/~nr/noweb|}, + Title = {Noweb -- A Simple, Extensible Tool for Literate Programming}} + +@misc{REF-Pu09, + Author = {Puffinware LLC}, + Date-Added = {2012-03-10 05:20:38 -0500}, + Date-Modified = {2012-03-10 05:21:23 -0500}, + Howpublished = {\verb|www.puffinwarellc.com/p3a.html|}, + Title = {Singular Value Decomposition (SVD) Tutorial}} + +@book{REF-PTVF95, + Author = {William H. Press, Saul A. Teukolsky, William T. Vetterling, Brian P. Flannery}, + Date-Added = {2012-03-10 05:16:32 -0500}, + Date-Modified = {2012-03-10 05:20:26 -0500}, + Keywords = {ISBN 0-521-43108-5}, + Publisher = {Cambridge University Press}, + Title = {Numerical Recipes in C}, + Year = {1995}} + +@article{REF-PM95, + Author = {David Lorge Parnas, Jan Madey}, + Date-Added = {2012-03-10 05:15:15 -0500}, + Date-Modified = {2012-03-10 05:16:11 -0500}, + Journal = {Science of Computer Programming}, + Month = {October}, + Number = {1}, + Pages = {41-61}, + Title = {Functional Documents for Computer Systems}, + Volume = {25}, + Year = {1995}} + +@article{REF-PJ10, + Author = {David Lorge Parnas, Ying Jin}, + Date-Added = {2012-03-10 05:13:55 -0500}, + Date-Modified = {2012-03-10 05:15:05 -0500}, + Journal = {Science of Computer Programming}, + Keywords = {Elsevier}, + Number = {11}, + Pages = {980-1000}, + Title = {Defining the meaning of tabular mathematical expressions}, + Volume = {75}, + Year = {2010}} + +@article{REF-Ost1845, + Author = {M. W. Ostrogradsky}, + Date-Added = {2012-03-10 04:50:07 -0500}, + Date-Modified = {2012-03-10 05:13:45 -0500}, + Journal = {Bulletin de Classe Physico-Math\'ematiques de L'Acad\'emie Imp\'eriale des Sciences de St. P\'etersbourg}, + Number = {145-167}, + Pages = {286-300}, + Title = {De l'int\'egration des fractions rationelles}, + Volume = {IV}, + Year = {1845}} + +@misc{REF-OpenM, + Date-Added = {2012-03-10 04:48:30 -0500}, + Date-Modified = {2012-03-10 04:48:55 -0500}, + Howpublished = {\verb|www.openmath.org/overview/technical.html|}, + Title = {OpenMath Technical Overview}} + +@book{REF-NIST10, + Date-Added = {2012-03-10 04:46:43 -0500}, + Date-Modified = {2012-03-10 04:48:23 -0500}, + Editor = {Frank W. Olver, Daniel W. Lozier, Ronald F. Boisvert, Charles W. Clark}, + Keywords = {ISBN 978-0-521-19225-5}, + Publisher = {Cambridge University Press}, + Title = {NIST Handbook of Mathematical Functions}, + Year = {2010}} + +@article{REF-Mul97, + Author = {Thom Mulders}, + Date-Added = {2012-03-10 04:45:19 -0500}, + Date-Modified = {2012-03-10 04:46:31 -0500}, + Journal = {Journal of Symbolic Computation}, + Number = {1}, + Pages = {45-50}, + Title = {A note on subresultants and a correction to the lazard/rioboo/trager formula in rational function integration}, + Volume = {24}, + Year = {1997}} + +@article{REF-Mie00, + Author = {Klaus D. Mielenz}, + Date-Added = {2012-03-10 04:44:14 -0500}, + Date-Modified = {2012-03-10 04:45:08 -0500}, + Journal = {Journal of Research (NIST)}, + Month = {July-August}, + Number = {4}, + Pages = {589-590}, + Title = {Computation of Fresnel Integrals II}, + Volume = {105}, + Year = {2000}} + +@article{REF-Mie97, + Author = {Klaus D. Mielenz}, + Date-Added = {2012-03-10 04:42:35 -0500}, + Date-Modified = {2012-03-10 04:44:02 -0500}, + Journal = {Journal of Research (NIST)}, + Month = {May-June}, + Number = {3}, + Pages = {363-365}, + Title = {Computation of Fresnel Integrals}, + Volume = {102}, + Year = {1997}} + +@misc{REF-Mar07, + Author = {U. Marshak}, + Date-Added = {2012-03-10 04:41:17 -0500}, + Date-Modified = {2012-03-10 04:42:15 -0500}, + Howpublished = {\verb|common-lisp.net/project/ht-ajax/ht-ajax.html|}, + Title = {HT-AJAX - AJAX framework for Hunchentoot}, + Year = {2007}} + +@misc{REF-LTW10, + Author = {Timothy Daly}, + Date-Added = {2012-03-10 04:40:01 -0500}, + Date-Modified = {2012-03-10 04:40:56 -0500}, + Howpublished = {\verb|lambda-the-ultimate.org/node/3663#comment-62440|}, + Title = {Lambda the Ultimate}} + +@misc{REF-Loe09, + Author = {Martin Loetzsch}, + Date-Added = {2012-03-10 04:39:04 -0500}, + Date-Modified = {2012-03-10 04:39:53 -0500}, + Howpublished = {\verb|martin-loetzsch.de/gtfl|}, + Title = {GTFL - A graphical terminal for Lisp}} + +@article{REF-Lio1933b, + Author = {Joseph Liouville}, + Date-Added = {2012-03-10 04:37:27 -0500}, + Date-Modified = {2012-03-10 04:38:31 -0500}, + Journal = {Journal de l'Ecole Polytechnique}, + Pages = {149-193}, + Title = {Second m\'emoire sur la d\'etermination des int\'egrales dont la valeur est alg\'ebraique}, + Volume = {14}, + Year = {1833}} + +@article{REF-Lio1833a, + Author = {Joseph Liouville}, + Date-Added = {2012-03-10 04:35:41 -0500}, + Date-Modified = {2012-03-10 04:37:21 -0500}, + Journal = {Journal de l'Ecole Polytechnique}, + Pages = {124-148}, + Title = {Premier m\'emoire sur la d\'etermination des int\'egrales dont la valeur est alg\'ebrique}, + Volume = {14}, + Year = {1833}} + +@book{REF-LMW79, + Author = {Richard C. Linger, Harlan D. Mills, Bernard I. Witt}, + Date-Added = {2012-03-10 04:33:40 -0500}, + Date-Modified = {2012-03-10 04:35:04 -0500}, + Keywords = {ISBN 0201144611}, + Month = {March}, + Publisher = {Addison-Wesley Publishing}, + Title = {Structured Programming: Theory and Practice}, + Year = {1979}} + +@article{REF-LR90, + Author = {Daniel Lazard, Renaud Rioboo}, + Date-Added = {2012-03-10 04:32:42 -0500}, + Date-Modified = {2012-03-10 04:33:31 -0500}, + Journal = {Journal of Symbolic Computation}, + Pages = {113-116}, + Title = {Integration of rational functions: Ration computation of the logarithmic part}, + Volume = {9}, + Year = {1990}} + +@article{REF-LR88, + Author = {D. Le Brigand, J. J. Risler}, + Date-Added = {2012-03-10 04:31:24 -0500}, + Date-Modified = {2012-03-10 04:32:33 -0500}, + Journal = {Bulletin of the Society of Mathematics}, + Pages = {231-253}, + Title = {Algorithme de Brill-Noether et codes de Goppa}, + Volume = {116}, + Year = {1988}} + +@book{REF-La86, + Author = {Leslie Lamport}, + Date-Added = {2012-03-10 04:30:19 -0500}, + Date-Modified = {2012-03-10 04:31:09 -0500}, + Keywords = {ISBN 0-201-15790-X}, + Publisher = {Addison-Wesley Publishing}, + Title = {A Document Preparation System}, + Year = {1986}} + +@book{REF-Kn92, + Address = {Stanford CA}, + Author = {Donald E. Knuth}, + Date-Added = {2012-03-10 04:29:15 -0500}, + Date-Modified = {2012-03-10 04:30:13 -0500}, + Keywords = {ISBN 0-937073-81-4}, + Publisher = {Center for the Study of Language and Information}, + Title = {Literate Programming}, + Year = {1992}} + +@book{REF-Knu84, + Author = {Donald Knuth}, + Date-Added = {2012-03-10 04:28:13 -0500}, + Date-Modified = {2012-03-10 04:29:07 -0500}, + Keywords = {ISBN 0-201-13448-9}, + Publisher = {Addison-Wesley Publishing}, + Title = {The \TeX{}book}, + Year = {1984}} + +@book{REF-KMJ00, + Author = {Matt Kaufmann, Panagiotis Manolios, J Strother Moore}, + Date-Added = {2012-03-10 04:26:41 -0500}, + Date-Modified = {2012-03-10 04:28:05 -0500}, + Keywords = {ISBN 0792377443}, + Month = {July}, + Publisher = {Springer}, + Title = {Computer-Aided Reasoning: An Approach}, + Year = {2000}} + +@book{REF-Je04, + Author = {Alan Jeffrey}, + Date-Added = {2012-03-10 04:25:04 -0500}, + Date-Modified = {2012-03-10 04:26:33 -0500}, + Keywords = {ISBN 0-12-382256-4}, + Publisher = {Elsevier Academic Press}, + Title = {Handbook of Mathematical Formulas and Integrals}, + Year = {2004}} + +@book{REF-Hou81, + Author = {Alston S. Householder}, + Date-Added = {2012-03-10 04:23:44 -0500}, + Date-Modified = {2012-03-10 04:24:56 -0500}, + Keywords = {ISBN 0-486-45312-X}, + Publisher = {Dover Publications}, + Title = {Principles of Numerical Analysis}, + Year = {1981}} + +@article{REF-HL95, + Author = {G. Hach\'e and D. Le Brigand}, + Date-Added = {2012-03-10 04:21:41 -0500}, + Date-Modified = {2012-03-10 04:23:33 -0500}, + Journal = {IEEE Transaction on Information Theory}, + Month = {November}, + Number = {27-6}, + Pages = {1615-1628}, + Title = {Effective construction of algebraic geometry codes}, + Volume = {41}, + Year = {1995}} + +@book{REF-HIg02, + Author = {Nicholas J. Higham}, + Date-Added = {2012-03-10 04:20:10 -0500}, + Date-Modified = {2012-03-10 04:21:22 -0500}, + Keywords = {ISBN 0-9871-521-0}, + Publisher = {SAIM}, + Title = {Accuracy and stability of numerical algorithms}, + Year = {2002}} + +@phdthesis{REF-Ha96, + Author = {G. Hach\'e}, + Date-Added = {2012-03-10 04:18:41 -0500}, + Date-Modified = {2012-03-10 04:19:41 -0500}, + Month = {September}, + School = {Universit\'e Pierre et Marie Curie (Paris 6)}, + Title = {Construction effective des codes g\'eom\'etriques}, + Year = {1995}} + +@article{REF-Ha95, + Author = {G. Hach\'e}, + Date-Added = {2012-03-10 04:17:17 -0500}, + Date-Modified = {2012-03-10 04:18:22 -0500}, + Journal = {Lecture Notes in Computer Science}, + Pages = {262-278}, + Title = {Computation in algebraic function fields for effective construction of algebraic-geometric codes}, + Volume = {948}, + Year = {1995}} + +@article{REF-Ga95, + Author = {A. Garcia, H. Stichtenoth}, + Date-Added = {2012-03-10 04:15:52 -0500}, + Date-Modified = {2012-03-10 04:17:08 -0500}, + Journal = {Invent. Math.}, + Pages = {211-222}, + Title = {A tower of Artin-Schreier extensions of function fields attaining the Drinfeld-Vladut bound}, + Volume = {121}, + Year = {1995}} + +@inproceedings{REF-Fl01, + Author = {John P. Fletcher}, + Booktitle = {AGACSE}, + Date-Added = {2012-03-10 04:14:28 -0500}, + Date-Modified = {2012-03-10 04:15:27 -0500}, + Keywords = {Paper 25}, + Title = {Symbolic processing of Clifford Numbers in C++}, + Year = {2001}} + +@techreport{REF-Bro98, + Author = {Manuel Bronstein}, + Date-Added = {2012-03-10 04:13:17 -0500}, + Date-Modified = {2012-03-10 04:14:15 -0500}, + Institution = {INRIA}, + Number = {RR-3562}, + Title = {The lazy hermite reduction}, + Type = {Research Report}, + Year = {1998}} + +@book{REF-Bro97, + Address = {Heidelberg, Germany}, + Author = {Manuel Bronstein}, + Date-Added = {2012-03-10 04:11:45 -0500}, + Date-Modified = {2012-03-10 04:13:03 -0500}, + Keywords = {ISBN 3-540-21493-3}, + Publisher = {Springer-Verlag}, + Title = {Symbolic Integration I -- Transcendental Functions}, + Year = {1997}} + +@techreport{REF-Ris69a, + Address = {Yorktown Heights, NY}, + Author = {Robert Risch}, + Date-Added = {2012-03-09 11:19:47 -0500}, + Date-Modified = {2012-03-09 11:20:54 -0500}, + Institution = {IBM Thomas J. Watson Research Center}, + Number = {RC-2042}, + Title = {Further results on elementary functions}, + Type = {Research Report}, + Year = {1969}} + +@article{REF-Ris79, + Author = {Robert Risch}, + Date-Added = {2012-03-09 05:28:19 -0500}, + Date-Modified = {2012-03-09 05:29:03 -0500}, + Journal = {American Journal of Mathematics}, + Pages = {743-759}, + Title = {Algebraic properties of the elementary functions of analysis}, + Volume = {101}, + Year = {1979}} + +@article{REF-Ro72, + Author = {Maxwell Rosenlicht}, + Date-Added = {2012-03-09 05:26:38 -0500}, + Date-Modified = {2012-03-09 05:27:56 -0500}, + Journal = {American Mathematical Monthly}, + Pages = {963-972}, + Title = {Integration in finite terms}, + Volume = {79}, + Year = {1972}} + +@inproceedings{REF-Ro77, + Author = {Michael Rothstein}, + Booktitle = {Proceedings of the 1977 MACSYMA Users Conference}, + Date-Added = {2012-03-09 05:25:10 -0500}, + Date-Modified = {2012-03-09 05:26:22 -0500}, + Pages = {263-274}, + Title = {A new algorithm for the integration of exponential and logarithmic functions}, + Volume = {NASA Pub CP-2012}, + Year = {1977}} + +@book{REF-Ste90, + Author = {Guy L. Steele}, + Date-Added = {2012-03-09 05:24:02 -0500}, + Date-Modified = {2012-03-09 05:24:55 -0500}, + Keywords = {ISBN 1-55558-041-6}, + Publisher = {Digital Press}, + Title = {Common Lisp The Language (2nd Edition)}, + Year = {1990}} + +@book{REF-St93, + Author = {Henning Stichtenoth}, + Date-Added = {2012-03-09 05:20:35 -0500}, + Date-Modified = {2012-03-09 05:23:16 -0500}, + Keywords = {ISBN 978-3-540-76877-7}, + Publisher = {Springer-Verlag}, + Series = {Graduate Texts in Mathematics}, + Title = {Algebraic Function Fields and Codes}, + Volume = {254}, + Year = {2008}} + +@book{REF-Tait1890, + Address = {\verb|www.archive.org/download/117770257/117770257.pdf|}, + Author = {Peter Guthrie Tait}, + Date-Added = {2012-03-09 05:16:26 -0500}, + Date-Modified = {2012-03-09 05:19:26 -0500}, + Keywords = {QA 257 T3 1890 MATH}, + Publisher = {Cambridge University Press}, + Title = {An elementary treatise on quaternions}, + Year = {1890}} + +@article{REF-Tai96, + Author = {Antero Taivalsaari}, + Date-Added = {2012-03-09 05:14:24 -0500}, + Date-Modified = {2012-03-09 05:15:15 -0500}, + Journal = {ACM Computing Surveys}, + Month = {September}, + Number = {3}, + Pages = {438-479}, + Title = {On the Notion of Inheritance}, + Volume = {28}, + Year = {1996}} + +@article{REF-Tr76, + Author = {Barry M. Trager}, + Date-Added = {2012-03-09 05:13:24 -0500}, + Date-Modified = {2012-03-09 05:14:15 -0500}, + Journal = {SYMSAC76}, + Pages = {219-226}, + Title = {Algebraic factoring and rational function integration}, + Year = {1976}} + +@phdthesis{REF-Tr84, + Author = {Barry M. Trager}, + Date-Added = {2012-03-09 05:12:24 -0500}, + Date-Modified = {2012-03-09 05:13:03 -0500}, + School = {MIT School of Computer Science}, + Title = {On the integration of algebraic functions}, + Year = {1984}} + +@article{REF-vH94, + Author = {M. van Hoeij}, + Date-Added = {2012-03-09 05:10:53 -0500}, + Date-Modified = {2012-03-09 05:12:16 -0500}, + Journal = {Journal of Symbolic Computation}, + Month = {October}, + Number = {4}, + Pages = {353-364}, + Title = {An algorithm for computing an integral basis in an algebraic function field}, + Volume = {18}, + Year = {1994}} + +@misc{REF-Wa03, + Author = {Stephen M. Watt}, + Date-Added = {2012-03-09 05:10:15 -0500}, + Date-Modified = {2012-03-09 05:10:41 -0500}, + Howpublished = {\verb|www.aldor.org|}, + Title = {Aldor}, + Year = {2003}} + +@misc{REF-Wein, + Author = {Eric W. Weisstein}, + Date-Added = {2012-03-09 05:09:17 -0500}, + Date-Modified = {2012-03-09 05:10:05 -0500}, + Howpublished = {\verb|mathworld.wolfram.com/HypergeometricFunction.html|}, + Title = {Hypergeometric Function}} + +@misc{REF-Wei03, + Author = {Edi Weitz}, + Date-Added = {2012-03-09 05:08:21 -0500}, + Date-Modified = {2012-03-09 05:09:01 -0500}, + Howpublished = {\verb|www.weitz.de/cl-who|}, + Title = {CL-WHO Yet another Lisp markup language}, + Year = {2003}} + +@misc{REF-Wei06, + Author = {Edi Weitz}, + Date-Added = {2012-03-09 05:07:30 -0500}, + Date-Modified = {2012-03-09 05:08:15 -0500}, + Howpublished = {\verb|www.weitz.de/hunchentoot|}, + Title = {HUNCHENTOOT - The Common Lisp web server}} + +@misc{REF-Wo09, + Date-Added = {2012-03-09 05:06:44 -0500}, + Date-Modified = {2012-03-09 05:07:18 -0500}, + Howpublished = {\verb|mathworld.wolfram.com/Quaternion.html|}, + Title = {Wolfram Research}} + +@misc{REF-Ham04, + Author = {S. Hamdy}, + Date-Added = {2012-03-09 05:04:43 -0500}, + Date-Modified = {2012-03-09 05:05:51 -0500}, + Howpublished = {\verb|www.cdc.informatik.tu-darmstadt.ed/TI/LiDIA|}, + Keywords = {Reference manual Edition 2.1.1}, + Month = {May}, + Title = {LiDIA A library for computational number theory}, + Year = {2004}} + +@book{REF-Hal96, + Author = {Arthur S. Hathaway}, + Date-Added = {2012-03-09 04:36:43 -0500}, + Date-Modified = {2012-03-09 04:58:54 -0500}, + Month = {February}, + Publisher = {\verb|www.gutenberg.org/dirs/etext06/pqtrn10p.pdf|}, + Title = {A Primer of Quaternions}, + Year = {2006}} + +@book{REF-GC89, + Author = {Gene H. Golub, Charles F. Van Loan}, + Date-Added = {2012-03-09 04:33:05 -0500}, + Date-Modified = {2012-03-09 04:34:57 -0500}, + Keywords = {ISBN 0-8018-3772-3}, + Publisher = {Johns Hopkins University Press}, + Title = {Matrix Computations}, + Year = {1989}} + +@article{REF-Flo63, + Author = {R. W. Floyd}, + Date-Added = {2012-03-09 04:31:02 -0500}, + Date-Modified = {2012-03-09 04:32:24 -0500}, + Journal = {Journal of the ACM}, + Number = {3}, + Pages = {316-333}, + Title = {Semantic Analysis and Operator Precedence}, + Volume = {10}, + Year = {1963}} + +@book{REF-CS03, + Author = {John H. Conway, Derek A. Smith}, + Date-Added = {2012-03-09 04:28:27 -0500}, + Date-Modified = {2012-03-09 04:30:34 -0500}, + Keywords = {ISBN 1-56881-134-9}, + Publisher = {A. K. Peters}, + Title = {On Quaternions and Octonions}, + Year = {2003}} + +@article{REF-Bro90, + Author = {Manuel Bronstein}, + Date-Added = {2012-03-09 04:24:24 -0500}, + Date-Modified = {2012-03-09 04:26:11 -0500}, + Journal = {Journal of Symbolic Computation}, + Month = {February}, + Number = {2}, + Pages = {117-173}, + Title = {On the integration of elementary functions}, + Volume = {9}, + Year = {1990}} + +@misc{REF-Bro88, + Author = {Manuel Bronstein}, + Date-Added = {2012-03-09 04:22:01 -0500}, + Date-Modified = {2012-03-09 04:22:53 -0500}, + Keywords = {ISSAC 1998 Rostock}, + Title = {Symbolic Integration Tutorial}} + +@article{REF-Bro90, + Author = {Manuel Bronstein}, + Date-Added = {2012-03-09 04:18:31 -0500}, + Date-Modified = {2012-03-09 04:21:10 -0500}, + Journal = {Journal of Symbolic Computation}, + Month = {September}, + Pages = {117-173}, + Title = {Integration of Elementary Functions}, + Volume = {9}, + Year = {1988}} + +@techreport{REF-Bro88a, + Address = {Yorktown Heights, NY}, + Author = {Manuel Bronstein}, + Date-Added = {2012-03-09 03:56:07 -0500}, + Date-Modified = {2012-03-09 04:17:45 -0500}, + Institution = {IBM Thomas J. Watson Research Center}, + Number = {RC13460}, + Title = {The Transcendental Risch Differential Equation}, + Type = {Research Report}, + Year = {1988}} + +@article{REF-Bro88, + Author = {Manuel Bronstein}, + Date-Added = {2012-03-09 03:53:59 -0500}, + Date-Modified = {2012-03-09 03:55:19 -0500}, + Journal = {Journal of Symbolic Computation}, + Month = {February}, + Pages = {49-60}, + Title = {The Transcendental Risch Differential Equation}, + Volume = {9}, + Year = {1990}} + +@article{REF-Ber95, + Author = {Bertrand Laurent}, + Date-Added = {2012-03-09 03:52:22 -0500}, + Date-Modified = {2012-03-09 03:53:45 -0500}, + Journal = {Applicable Algebra in Engineering, Communications and Computing}, + Pages = {275-298}, + Title = {Computing a hyperelliptic integral using arithmetic in the jacobian of the curve}, + Volume = {6}, + Year = {1995}} + +@misc{REF-Ba10, + Author = {Martin Baker}, + Date-Added = {2012-03-09 03:51:35 -0500}, + Date-Modified = {2012-03-09 03:52:05 -0500}, + Howpublished = {\verb|www.euclideanspace.com|}, + Title = {3D World Simulation}} + +@book{REF-Alt05, + Author = {Simon L. Altmann}, + Date-Added = {2012-03-09 03:50:35 -0500}, + Date-Modified = {2012-03-09 03:51:27 -0500}, + Keywords = {ISBN 0-486-44518-6}, + Publisher = {Dover Publications}, + Title = {Rotations, Quaternions, and Double Groups}, + Year = {2005}} + +@book{REF-AS64, + Address = {New York, NY 10036 USA}, + Author = {Milton Abramowitz, Irene A. Stegun}, + Date-Added = {2012-03-09 03:48:50 -0500}, + Date-Modified = {2012-03-09 03:50:24 -0500}, + Keywords = {ISBN 0-486-61272-4}, + Publisher = {Dover Publications}, + Title = {Handbook of Mathematical Functions}, + Year = {1964}} + +@article{REF-Ab98, + Author = {Rafal Ablamowicz}, + Date-Added = {2012-03-09 03:47:26 -0500}, + Date-Modified = {2012-03-09 03:48:36 -0500}, + Journal = {Computer Physics Communications}, + Month = {December 11}, + Number = {2-3}, + Pages = {510-535}, + Title = {Spinor Representations of Clifford Algebras: A Symbolic Approach}, + Volume = {115}, + Year = {1988}} + +@inproceedings{Web93, + Address = {Berlin, Germany}, + Author = {A. Weber}, + Booktitle = {Design and Implementation of Symbolic Computation Systems}, + Date-Added = {2012-03-09 03:44:12 -0500}, + Date-Modified = {2012-03-09 03:45:25 -0500}, + Editor = {A. Miola}, + Keywords = {ISBN 3-540-57235-X LCCN QA76.9.S88I576}, + Month = {September}, + Organization = {Springer-Verlag}, + Pages = {95-106}, + Publisher = {Springer-Verlag}, + Title = {On coherence in computer algebra}, + Year = {1993}} + +@inproceedings{Sut85, + Address = {Berlin, Germany}, + Author = {Robert S. Sutor}, + Booktitle = {European Conference on Computer Algebra}, + Date-Added = {2012-03-09 03:42:17 -0500}, + Date-Modified = {2012-03-09 03:43:52 -0500}, + Editor = {Bruno Buchberger, Bob F. Caviness}, + Keywords = {ISBN 0-387-15983-5 LLCN QA155.7.E4 E86 1985BC85v2}, + Month = {April 1-3}, + Organization = {Springer-Verlag}, + Pages = {32-33}, + Publisher = {Springer-Verlag}, + Title = {The Scratchpad II Computer Algebra Language and System}, + Volume = {Vol 1 of 2}, + Year = {1985}} + +@inproceedings{SJ87a, + Address = {New York, NY 10036 USA}, + Author = {Robert S. Sutor, Richard D. Jenks}, + Booktitle = {SIGPLAN 87 Symposium on Interpreter and Interpretive Techniques}, + Date-Added = {2012-03-09 03:39:58 -0500}, + Date-Modified = {2012-03-09 03:41:24 -0500}, + Editor = {Richard L. Wexelblat}, + Keywords = {ISBN 0-89791-235-7 LCCN QA76.7.S54}, + Month = {June 24-26}, + Number = {7}, + Organization = {Association for Computing Machinery}, + Pages = {56-63}, + Publisher = {ACM Press}, + Title = {The type inference and coercion facilities in the Scratchpad II interpreter}, + Volume = {22}, + Year = {1987}} + +@inproceedings{Sit88, + Address = {Berlin, Germany}, + Author = {William Y. Sit}, + Booktitle = {Applied Algebra, Algebraic Algorithms and Error-Correcting Codes}, + Date-Added = {2012-03-09 03:38:01 -0500}, + Date-Modified = {2012-03-09 03:39:30 -0500}, + Editor = {T. Mora}, + Keywords = {ISBN 3-540-51083-4 LCCN QA268.A35 1988}, + Number = {357}, + Organization = {Springer-Verlag}, + Publisher = {Springer-Verlag}, + Series = {Lecture Notes in Computer Science}, + Title = {On Goldman's algorithm for solving first-order multinomial autonomous systems}, + Year = {1988}} + +@inproceedings{Sei94a, + Address = {Karlsruhe, Germany}, + Author = {W. M. Seiler}, + Booktitle = {Rhine Workshop on Computer Algebra}, + Date-Added = {2012-03-09 03:36:32 -0500}, + Date-Modified = {2012-03-09 03:37:38 -0500}, + Editor = {J. Calmet}, + Organization = {Universit{\"a}t Karlsruhe}, + Publisher = {Universit{\"a}t Karlsruhe}, + Title = {Completion to involution in AXIOM}, + Year = {1994}} + +@inproceedings{Pet93, + Address = {Lille France}, + Author = {M. Petitot}, + Booktitle = {Internationa IMACS Symposium on Symbolic Computation}, + Date-Added = {2012-03-09 03:35:00 -0500}, + Date-Modified = {2012-03-09 03:36:07 -0500}, + Editor = {G. Jacob, N. E. Oussous, S. Steinberg}, + Organization = {LIFL University}, + Title = {Experience with Axiom}, + Year = {1993}} + +@inbook{Yun83, + Author = {David Y. Y. Yun}, + Chapter = {Computer Algebra and Complex Analysis}, + Date-Added = {2012-03-09 03:32:30 -0500}, + Date-Modified = {2012-03-09 03:34:30 -0500}, + Editor = {H. Werner}, + Number = {379-393}, + Publisher = {D. Reidel}, + Title = {Computational Aspects of Complex Analysis}, + Year = {1983}} + +@inproceedings{Sch89, + Address = {New York, NY 10036 USA}, + Author = {F. Schwarz}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-09 03:15:45 -0500}, + Date-Modified = {2012-03-09 03:31:56 -0500}, + Keywords = {ISBN 0-89791-325-6 LCCN QA76.95.I59 1989}, + Organization = {Association for Computing Machinery}, + Pages = {17-25}, + Publisher = {ACM Press}, + Title = {A factorization algorithm for linear ordinary differential equations}, + Year = {1989}} + +@inproceedings{Oll89, + Address = {New York, NY 10036 USA}, + Author = {F. Ollivier}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-09 03:11:55 -0500}, + Date-Modified = {2012-03-09 03:14:59 -0500}, + Keywords = {ISBN 0-89791-325-6 LCCN QA76.95.I59 1989}, + Organization = {Association for Computing Machinery}, + Pages = {43-54}, + Publisher = {ACM Press}, + Title = {Inversibility of rational mappings and structural identifiability in automatics}, + Year = {1989}} + +@proceedings{Wex87, + Address = {New York, NY 10036 USA}, + Date-Added = {2012-03-09 03:07:02 -0500}, + Date-Modified = {2012-03-09 03:10:08 -0500}, + Editor = {Richard L. Wexelblat}, + Keywords = {ISBN 0-89791-235-7 LCCN QA76.7.S54}, + Month = {June 24-26}, + Number = {7}, + Organization = {Association for Computing Machinery}, + Publisher = {ACM Press}, + Title = {SIGPLAN 87 Symposium on Interpreter and Interpretive Techniques}, + Volume = {22}, + Year = {1987}} + +@article{Wan89, + Author = {D. Wang}, + Date-Added = {2012-03-09 03:04:59 -0500}, + Date-Modified = {2012-03-09 03:06:24 -0500}, + Journal = {SIGSAM Bulletin}, + Keywords = {CODEN SIGSBZ ISSN 0163-5824}, + Month = {October}, + Number = {4}, + Pages = {25-31}, + Title = {A program for computing the Liapunov functions and Liapunov constants in Scratchpad II}, + Volume = {23}, + Year = {1989}} + +@inproceedings{SSC92, + Address = {\verb|iaks-www.ira.uka.de/iaks-calmet/werner/Papers/Acireale92.ps.gz|}, + Booktitle = {Advanced Analytical and Computational Methods in Mathematical Physics}, + Date-Added = {2012-03-09 02:59:56 -0500}, + Date-Modified = {2012-03-09 03:03:14 -0500}, + Editor = {N. Ibragimov, M. Torrisis, A. Valenti}, + Organization = {Kluwer}, + Pages = {337-344}, + Publisher = {Kluwer Academic Publishers}, + Series = {Modern Group Analysis}, + Title = {Algorithmic Methods For Lie Pseudogroups}, + Year = {1992}} + +@inproceedings{Sme92, + Address = {New York, NY 10036 USA}, + Author = {Trevor J. Smedley}, + Booktitle = {Applied Computing -- Technological Challenges for the 1990s}, + Date-Added = {2012-03-09 02:53:23 -0500}, + Date-Modified = {2012-03-09 02:57:02 -0500}, + Editor = {Hal Berghel}, + Keywords = {ISBN 0-89791-502-X LCCN QA76.76.A65.S95 1992}, + Month = {March 1-3}, + Pages = {1243-1247}, + Publisher = {ACM Press}, + Series = {Symposium on Applied Computing}, + Title = {Using pictorial and object oriented programming for computer algebra}, + Year = {1992}} + +@mastersthesis{Sch92, + Address = {Universit{\"a}t Karlsruhe}, + Author = {J. Sch\"u}, + Date-Added = {2012-03-09 02:50:08 -0500}, + Date-Modified = {2012-03-09 02:51:32 -0500}, + School = {Institut f\"ur Algorithmen und Kognitive Systeme}, + Title = {Implementing des Cartan-Kuranishi-Theorems in AXIOM}, + Year = {1992}} + +@inproceedings{Roe95, + Author = {K. G. Roesner}, + Booktitle = {Zeitschrift f\"ur Angewandte Mathematik und Physik}, + Date-Added = {2012-03-09 02:41:38 -0500}, + Date-Modified = {2012-03-09 02:43:48 -0500}, + Keywords = {S435-S438 ISSN 0044-2267}, + Number = {suppl. 2}, + Title = {Verified solutions for parameters of an exact solution for non-Newtonian liquids using computer algebra}, + Volume = {75}, + Year = {1995}} + +@inproceedings{Pur86, + Address = {New York, NY 10036 USA}, + Author = {J. Purtilo}, + Booktitle = {Symposium on Symbolic and Algebraic Compution}, + Date-Added = {2012-03-09 02:38:13 -0500}, + Date-Modified = {2012-03-09 02:40:18 -0500}, + Editor = {Bruce W. Char}, + Keywords = {ISBN 0-89791-199-7 LCCN QA155.7.E4.A281 1986 ACM Order Number 505860}, + Month = {July 21-23}, + Organization = {Association for Computing Machinery}, + Publisher = {ACM Press}, + Title = {Applications of a software interconnection system in mathematical problem solving environments}, + Year = {1986}} + +@inproceedings{Pa07, + Address = {New York, NY 10036 USA}, + Author = {William S. Page}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-09 02:29:14 -0500}, + Date-Modified = {2012-03-09 02:32:23 -0500}, + Month = {September}, + Number = {3}, + Organization = {Association for Computing Machinery}, + Pages = {114}, + Publisher = {ACM Press}, + Title = {Axiom- Open Source Computer Algebra System}, + Volume = {41}, + Year = {2007}} + +@proceedings{Mor88, + Address = {Berlin, Germany}, + Date-Added = {2012-03-09 02:26:00 -0500}, + Date-Modified = {2012-03-09 02:28:03 -0500}, + Editor = {T. Mora}, + Keywords = {ISBN 3-540-51083-4 LCCN QA268.A35 1988}, + Organization = {Springer-Verlag}, + Publisher = {Springer-Verlag}, + Title = {Applied Algebra, Algebraic Algorithms and Error-Correcting Codes}, + Volume = {357 of Lecture Notes in Computer Science}, + Year = {1988}} + +@inproceedings{Mon93, + Address = {Berlin, Germany}, + Author = {Michael B. Monagan}, + Booktitle = {Design and Implementation of Symbolic Computation Systems}, + Date-Added = {2012-03-09 02:19:24 -0500}, + Date-Modified = {2012-03-09 02:21:55 -0500}, + Editor = {A. Miola}, + Keywords = {ISBN 3-540-57235-X LCCN QA76.9.S88I576}, + Month = {September}, + Organization = {Springer-Verlag}, + Pages = {81-94}, + Publisher = {Springer-Verlag}, + Title = {Gauss: a parameterized domain of computation system with support for signature functions}, + Year = {1993}} + +@proceedings{Mio93, + Address = {Berlin, Germany}, + Date-Added = {2012-03-09 02:16:26 -0500}, + Date-Modified = {2012-03-09 02:18:49 -0500}, + Editor = {A. Miola}, + Keywords = {ISBN 3-540-57235-X LCCN QA76.9.S88I576}, + Month = {September}, + Organization = {Springer-Verlag}, + Publisher = {Springer-Verlag}, + Title = {Design and Implementation of Symbolic Computation Systems}, + Year = {1993}} + +@inproceedings{Mah05, + Author = {Assia Mahboubi}, + Booktitle = {Mathematics, Algorithms, Proofs}, + Date-Added = {2012-03-09 02:04:08 -0500}, + Date-Modified = {2012-03-09 02:09:41 -0500}, + Publisher = {Schloss Dagstuhl}, + Series = {Dagstuhl Seminar Proceedings}, + Title = {Programming and certifying the CAD algorithm inside the COQ system}, + Volume = {05021}, + Year = {2005}} + +@mastersthesis{Lue77, + Address = {Braunschweig, Germany}, + Author = {E. Lueken}, + Date-Added = {2012-03-09 02:00:13 -0500}, + Date-Modified = {2012-03-09 02:01:49 -0500}, + School = {Technischen Universit\"at Carolo-Wilhelmina zu Branuschweig}, + Title = {Ueberlegungen zur Implementierung eines Formelmanipulationsystems}, + Year = {1977}} + +@inproceedings{Luc86, + Address = {New York, NY 10036 USA}, + Author = {Michael Lucks}, + Booktitle = {Symposium on Symbolic and Algebraic Compution}, + Date-Added = {2012-03-09 01:56:15 -0500}, + Date-Modified = {2012-03-09 01:59:31 -0500}, + Editor = {Bruce W. Char}, + Keywords = {ISBN 0-89791-199-7 LCCN QA155.7.E4.A281 1986 ACM Order Number 505860}, + Month = {July 21-23}, + Organization = {Association for Computing Machinery}, + Pages = {21-23}, + Publisher = {ACM Press}, + Title = {A fast implementation of polynomial factorization}, + Volume = {SYMSAC86}, + Year = {1986}} + +@inproceedings{LM06, + Address = {\verb|www.csd.uwo.ca/~moreno/Publications/Li-MorenoMaza-ICMS-06.pdf|}, + Author = {Xin Li, Moreno Maza}, + Booktitle = {International Congress of Mathematical Software}, + Date-Added = {2012-03-08 15:50:10 -0500}, + Date-Modified = {2012-03-08 15:55:17 -0500}, + Keywords = {ISBN 978-3-540-38084-9}, + Organization = {Springer-Verlag}, + Pages = {12-23}, + Publisher = {Springer-Verlag}, + Series = {Lecture Notes in Computer Science}, + Title = {Efficient Implementation of Polynomial Arithmetic in a Multiple-Level Programming Environment}, + Volume = {4151}, + Year = {2006}} + +@article{Mat89, + Author = {J. Mathews}, + Date-Added = {2012-03-08 15:47:09 -0500}, + Date-Modified = {2012-03-08 15:48:59 -0500}, + Journal = {Mathematics and Computer Education}, + Keywords = {CODEN MCEDDA ISSN 0730-8639}, + Month = {Spring}, + Number = {2}, + Pages = {117-122}, + Title = {Symbolic computational algebra applied to Picard iteration}, + Volume = {23}, + Year = {1989}} + +@article{REF-SDDD12, + Author = {Eric Schulte, Dan Davis, Thomas Dye, Carsten Dominik}, + Date-Added = {2012-03-26 15:47:09 -0500}, + Date-Modified = {2012-03-26 15:48:59 -0500}, + Journal = {Journal of Statistical Software}, + Keywords = {http://www.jstatsoft.org/v46/i03/paper}, + Month = {January}, + Number = {3}, + Title = {A Multi-Language Computing Environment for Literate Programming and ReproducibleResearch}, + Volume = {46}, + Year = {2012}} + +@article{MR90, + Author = {E. Melachrinoudis, D. L. Rumpf}, + Date-Added = {2012-03-08 15:44:31 -0500}, + Date-Modified = {2012-03-08 15:46:49 -0500}, + Journal = {CoED}, + Keywords = {CODEN CWLJDP ISSN 0736-8607}, + Month = {January-March}, + Number = {1}, + Pages = {71-76}, + Title = {Teaching advantages of transparent computer software -- MathCAD}, + Volume = {10}, + Year = {1990}} + +@article{Sal91, + Author = {B. Salvy}, + Date-Added = {2012-03-08 15:41:29 -0500}, + Date-Modified = {2012-03-08 15:42:44 -0500}, + Journal = {SIGSAM Bulletin}, + Keywords = {CODEN SIGSBZ ISSN 0163-5824}, + Month = {April}, + Number = {2}, + Pages = {4-17}, + Title = {Examples of automatic asymptotic expansions}, + Volume = {25}, + Year = {1991}} + +@article{Sch91, + Author = {F. Schwarz}, + Date-Added = {2012-03-08 15:40:00 -0500}, + Date-Modified = {2012-03-08 15:41:18 -0500}, + Journal = {SIGSAM Bulletin}, + Keywords = {CODEN SIGSBZ ISSN 0163-5824}, + Month = {January}, + Pages = {10-23}, + Title = {Monomial orderings and Gr\"obner bases}, + Year = {1991}} + +@article{Sie94b, + Author = {W. M. Seiler}, + Date-Added = {2012-03-08 15:37:18 -0500}, + Date-Modified = {2012-03-08 15:39:28 -0500}, + Journal = {Computer Physics Communications}, + Keywords = {CODEN CPHCBZ ISSN 0010-4655}, + Month = {April}, + Number = {2}, + Pages = {329-340}, + Title = {Pseudo differential operators and integrable systems in AXIOM}, + Volume = {79}, + Year = {1994}} + +@article{SS88, + Author = {D. Shannon, M. Sweedler}, + Date-Added = {2012-03-08 15:35:10 -0500}, + Date-Modified = {2012-03-08 15:36:49 -0500}, + Journal = {Journal of Symbolic Computation}, + Keywords = {CODEN JSYCEH ISSN 0747-7171}, + Month = {October-December}, + Number = {2-3}, + Pages = {267-273}, + Title = {Using Gr\"obner bases to determine algebra membership, split surjective algebra homomorphisms determine birational equivalence}, + Volume = {6}, + Year = {1988}} + +@techreport{SSV87, + Address = {Grenoble, France}, + Author = {P. Senechaud, F. Siebert, G. Villard}, + Date-Added = {2012-03-08 15:32:54 -0500}, + Date-Modified = {2012-03-08 15:34:49 -0500}, + Institution = {TIM 3 (IMAG)}, + Month = {February}, + Number = {640-M}, + Title = {Scratchpad II: Pr\'esentation d'un nouveau langage de calcul formel}, + Type = {Technical Report}, + Year = {1987}} + +@article{vH94, + Author = {M. van Hoeij}, + Date-Added = {2012-03-08 15:31:07 -0500}, + Date-Modified = {2012-03-08 15:32:39 -0500}, + Journal = {Journal of Symbolic Computation}, + Keywords = {CODEN JSYCEH ISSN 0747-7171}, + Month = {October}, + Number = {4}, + Pages = {353-363}, + Title = {An algorithm for computing an integral basis in an algebraic function field}, + Volume = {18}, + Year = {1994}} + +@inproceedings{WJST90, + Author = {Stephen M. Watt, Richard D. Jenks, Robert S. Sutor, Barry M. Trager}, + Booktitle = {Computing Tools for Scientific Problem Solving}, + Date-Added = {2012-03-08 15:27:55 -0500}, + Date-Modified = {2012-03-08 15:30:31 -0500}, + Editor = {A. M. Miola}, + Title = {The Scratchpad II type system: Domains and subdomains}, + Year = {1990}} + +@phdthesis{Zen92, + Address = {Karlsruhe, Germany}, + Author = {Ch. Zenger}, + Date-Added = {2012-03-08 15:15:15 -0500}, + Date-Modified = {2012-03-08 15:16:50 -0500}, + School = {Universit{\"a}t Karlsruhe}, + Title = {Gr\"obnerbasen f\"ur Differentialformen und ihre Implementierung in AXIOM}, + Year = {1992}} + +@book{Yap00, + Author = {Chee Keng Yap}, + Date-Added = {2012-03-08 13:59:23 -0500}, + Date-Modified = {2012-03-08 14:01:03 -0500}, + Keywords = {ISBN 0-19-512516-9}, + Publisher = {Oxford University Press}, + Title = {Fundamental Problems of Algorithmic Algebra}, + Year = {2000}} + +@article{Wan91, + Author = {Dongming Wang}, + Date-Added = {2012-03-08 13:57:46 -0500}, + Date-Modified = {2012-03-08 13:59:03 -0500}, + Journal = {Journal of Symbolic Computation}, + Keywords = {CODEN JSYCEH ISSN 0747-7171}, + Month = {August}, + Number = {2}, + Pages = {233-254}, + Title = {Mechanical manipulation for a class of differential systems}, + Volume = {12}, + Year = {1991}} + +@misc{Su87, + Author = {Robert S. Sutor}, + Date-Added = {2012-03-08 13:55:34 -0500}, + Date-Modified = {2012-03-08 13:57:20 -0500}, + Howpublished = {IBM Course presentation slide deck}, + Month = {Spring}, + Title = {The Scratchpad II Computer Algebra System. Using and Programming the Interpreter}, + Year = {1987}} + +@article{Sit92, + Author = {William Y. Sit}, + Date-Added = {2012-03-08 13:54:10 -0500}, + Date-Modified = {2012-03-08 13:55:22 -0500}, + Journal = {Journal of Symbolic Computation}, + Keywords = {CODEN JSYCEH ISSN 0747-7171}, + Month = {April}, + Number = {4}, + Pages = {353-394}, + Title = {An algorithm for solving parametric linear systems}, + Volume = {13}, + Year = {1992}} + +@techreport{Sei95, + Author = {W. M. Seiler}, + Date-Added = {2012-03-08 13:52:13 -0500}, + Date-Modified = {2012-03-08 13:53:39 -0500}, + Institution = {Universit{\"a}t Karlsruhe, Fakult\"at f\"ur Informatik}, + Number = {95-17}, + Title = {Applying AXIOM to partial differential equations}, + Type = {Internal Report}, + Year = {1995}} + +@techreport{Sal89, + Address = {Le Chesnay, France}, + Author = {B. Salvy}, + Date-Added = {2012-03-08 13:50:03 -0500}, + Date-Modified = {2012-03-08 13:51:52 -0500}, + Institution = {Institut National de Recherche en Informatique et en Automatique}, + Keywords = {18pp}, + Month = {December}, + Number = {114}, + Title = {Examples of automatic asymptotic expansions}, + Type = {Technical Report}, + Year = {1989}} + +@article{Nor75, + Author = {Arthur C. Norman}, + Date-Added = {2012-03-08 13:40:19 -0500}, + Date-Modified = {2012-03-08 13:41:43 -0500}, + Journal = {ACM Transactions on Mathematical Software}, + Keywords = {CODEN ACMSCU ISSN 0098-3500}, + Month = {December}, + Number = {4}, + Pages = {346-356}, + Title = {Computing with formal power series}, + Volume = {1}, + Year = {1975}} + +@article{Mos71, + Author = {Joel Moses}, + Date-Added = {2012-03-08 13:38:42 -0500}, + Date-Modified = {2012-03-08 13:39:45 -0500}, + Journal = {Communications of the ACM}, + Month = {August}, + Number = {8}, + Pages = {527-537}, + Title = {Algebraic Simplification: A Guide for the Perplexed}, + Volume = {14}, + Year = {1971}} + +@article{LM91, + Author = {R. Lynch and H. A. Mavromatis}, + Date-Added = {2012-03-08 13:19:10 -0500}, + Date-Modified = {2012-03-08 13:20:47 -0500}, + Journal = {American Journal of Physics}, + Keywords = {ISSN 0002-9505}, + Month = {March}, + Number = {3}, + Pages = {270-273}, + Title = {New quantum mechanical perturbation technique using an electronic scratchpad on an inexpensive computer}, + Volume = {59}, + Year = {1991}} + +@misc{LD97, + Author = {Richard Liska, Ladislav Drska, Jiri Limpouch, Milan Sinor, Michael Wester, Franz Winkler}, + Date-Added = {2012-03-08 13:05:28 -0500}, + Date-Modified = {2012-03-08 13:07:13 -0500}, + Howpublished = {\verb|kfe.fjfi.cvut.cz/~liska/ca/all.html|}, + Month = {June 2}, + Title = {Computer Algebra - Algorithms, Systems and Applications}, + Year = {1997}} + +@misc{Le96, + Author = {Gr\'egoire Lecerf}, + Date-Added = {2012-03-08 13:03:54 -0500}, + Date-Modified = {2012-03-08 13:05:13 -0500}, + Howpublished = {\verb|www.math.uvsq.fr/~lecerf/software/drc/drc.ps|}, + Month = {June 29}, + Title = {Dynamic Evaluation and Real Closure Implementation in Axiom}, + Year = {1996}} + +@phdthesis{Leb08, + Address = {\verb|www.math.fsu.edu/~ylebedev/research/HyperbolicGeometry.html|}, + Author = {Yuri Lebedev}, + Date-Added = {2012-03-08 12:58:46 -0500}, + Date-Modified = {2012-03-08 13:00:01 -0500}, + Month = {November}, + School = {Florida State University}, + Title = {OpenMath Library for Computing on Riemann Surfaces}, + Year = {2008}} + +@inproceedings{LeB91, + Address = {Washington, DC, USA}, + Author = {S. E. LeBlanc}, + Booktitle = {Challenges of a Changing World}, + Date-Added = {2012-03-08 12:35:58 -0500}, + Date-Modified = {2012-03-08 12:37:24 -0500}, + Keywords = {2 volumes}, + Organization = {American Society for Engineering Education}, + Pages = {287-299}, + Title = {The use of MathCAD and Theorist in the ChE classroom}, + Year = {1991}} + +@article{Lam91, + Author = {Larry A. Lambe}, + Date-Added = {2012-03-08 12:34:26 -0500}, + Date-Modified = {2012-03-08 12:35:31 -0500}, + Journal = {Journal of Symbolic Computation}, + Keywords = {ISSN 0747-7171}, + Month = {July}, + Number = {1}, + Pages = {71-87}, + Title = {Resolutions via homological perturbation}, + Volume = {12}, + Year = {1991}} + +@article{Kos91, + Author = {P.-V. Koseleff}, + Date-Added = {2012-03-08 12:27:27 -0500}, + Date-Modified = {2012-03-08 12:33:42 -0500}, + Journal = {Theoretical Computer Science}, + Keywords = {ISSN 0304-3975}, + Month = {February}, + Number = {1}, + Pages = {241-256}, + Title = {Word games in free Lie algebras: several bases and formulas}, + Volume = {79}, + Year = {1991}} + +@techreport{KN94, + Address = {\verb|www.nag.co.uk/doc/TechRep/axiomtr.html|}, + Author = {G. Keady, G. Nolan}, + Date-Added = {2012-03-08 12:23:21 -0500}, + Date-Modified = {2012-03-08 12:24:48 -0500}, + Institution = {Numerical Algorithms Group}, + Number = {TR1/94 (ATR/7)(NP2680)}, + Title = {Production of Argument SubPrograms in the AXIOM--NAG link: examples involving nonlinear systems}, + Type = {Technical Report}, + Year = {1994}} + +@phdthesis{Kel99, + Author = {Tom Kelsey}, + Date-Added = {2012-03-08 12:21:24 -0500}, + Date-Modified = {2012-03-08 12:22:55 -0500}, + Keywords = {\verb|www.cs.st-andrews.ac.uk/research/publications/Kel00.php|}, + School = {University of St Andrews}, + Title = {Formal Methods and Computer Algebra: A Larch Specification of AXIOM Categories and Functors}, + Year = {1999}} + +@inproceedings{JT94, + Address = {New York, NY 10036 USA}, + Author = {Richard D. Jenks, Barry M. Trager}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-08 12:17:59 -0500}, + Date-Modified = {2012-03-08 12:19:37 -0500}, + Keywords = {ISBN 0-89791-638-7 LCCN QA76.95.I59 1994}, + Organization = {Association for Computing Machinery}, + Pages = {32-40}, + Publisher = {ACM Press}, + Title = {How to make AXIOM into a Scratchpad}, + Year = {1994}} + +@inproceedings{Sch88, + Address = {Berlin, Germany}, + Author = {F. Schwarz}, + Booktitle = {Trends in Computer Algebra}, + Date-Added = {2012-03-08 12:12:29 -0500}, + Date-Modified = {2012-03-08 12:14:31 -0500}, + Editor = {R. Jan{\ss}en}, + Keywords = {ISBN 3-540-18928-6 LCCN QA155.7.E4T74 1988}, + Month = {May 19-21}, + Organization = {Springer-Verlag}, + Pages = {167-176}, + Publisher = {Springer-Verlag}, + Series = {Lecture Notes in Computer Science}, + Title = {Programming with abstract data types: the symmetry package SPDE in Scratchpad}, + Volume = {296}, + Year = {1987}} + +@inproceedings{JWS88, + Address = {Berlin, Germany}, + Author = {Richard D. Jenks, Robert S. Sutor, Stephen M. Watt}, + Booktitle = {Trends in Computer Algebra}, + Date-Added = {2012-03-08 12:09:58 -0500}, + Date-Modified = {2012-03-08 12:12:03 -0500}, + Editor = {R. Jan{\ss}en}, + Keywords = {ISBN 3-540-18928-6 LCCN QA155.7.E4T74 1988}, + Month = {May 19-21}, + Organization = {Springer-Verlag}, + Pages = {12-37}, + Publisher = {Springer-Verlag}, + Series = {Lecture Notes in Computer Science}, + Title = {Scratchpad II: an abstract datatype system for mathematical computation}, + Volume = {296}, + Year = {1987}} + +@inproceedings{JWS87, + Author = {Richard D. Jenks, Robert S. Sutor, Stephen M. Watt}, + Booktitle = {Trends in Computer Algebra}, + Date-Added = {2012-03-08 12:06:06 -0500}, + Date-Modified = {2012-03-08 12:07:36 -0500}, + Organization = {Springer-Verlag}, + Title = {Scratchpad II: an abstract datatype system for mathematical computation}, + Volume = {LNCS 296}, + Year = {1987}} + +@proceedings{JOS93, + Address = {Lille France}, + Date-Added = {2012-03-08 12:04:26 -0500}, + Date-Modified = {2012-03-08 12:05:43 -0500}, + Editor = {G. Jacob, N. E. Oussous, S. Steinberg}, + Organization = {LIFL University}, + Title = {Internationa IMACS Symposium on Symbolic Computation}, + Year = {1993}} + +@article{JT81a, + Author = {Richard D. Jenks, Barry M. Trager}, + Date-Added = {2012-03-08 12:03:03 -0500}, + Date-Modified = {2012-03-08 12:03:55 -0500}, + Journal = {SIGPLAN Notices}, + Month = {November}, + Title = {A Language for Computational Algebra}, + Year = {1981}} + +@inproceedings{JT81, + Author = {Richard D. Jenks, Barry M. Trager}, + Booktitle = {Symposium on Symbolic and Algebraic Compution}, + Date-Added = {2012-03-08 11:14:02 -0500}, + Date-Modified = {2012-03-08 11:14:55 -0500}, + Month = {August}, + Title = {A Language for Computational Algebra}, + Year = {1981}} + +@inproceedings{Jen84b, + Address = {Berlin, Germany}, + Author = {Richard D. Jenks}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-08 11:09:26 -0500}, + Date-Modified = {2012-03-08 11:11:38 -0500}, + Editor = {J. P. Fitch}, + Keywords = {ISBN 0-387-13350-X LCCN QA155.7.E4.I57 1984}, + Month = {July 9-11}, + Organization = {Springer-Verlag}, + Pages = {123-147}, + Publisher = {Springer-Verlag}, + Title = {A primer: 11 keys to New Scratchpad}, + Year = {1984}} + +@inproceedings{Jen84a, + Address = {Schenectady, NY, USA}, + Author = {Richard D. Jenks}, + Booktitle = {1984 MACSYMA Users Conference}, + Date-Added = {2012-03-08 09:41:11 -0500}, + Date-Modified = {2012-03-08 09:42:58 -0500}, + Editor = {V. Ellen Golden, M. A. Hussain}, + Month = {July 23-25}, + Organization = {General Electric}, + Pages = {409}, + Publisher = {General Electric}, + Title = {The new SCRATCHPAD language and system for computer algebra}, + Year = {1984}} + +@article{Jen74, + Author = {Richard D. Jenks}, + Date-Added = {2012-03-08 09:32:54 -0500}, + Date-Modified = {2012-03-08 09:33:50 -0500}, + Journal = {ACM SIGPLAN Notices}, + Keywords = {ISSN 0362-1340}, + Number = {4}, + Pages = {101-111}, + Title = {The SCRATCHPAD language}, + Volume = {9}, + Year = {1974}} + +@techreport{Jen69, + Address = {Yorktown Heights, NY}, + Author = {Richard D. Jenks}, + Date-Added = {2012-03-08 09:31:42 -0500}, + Date-Modified = {2012-03-08 09:32:32 -0500}, + Institution = {IBM Thomas J. Watson Research Center}, + Title = {META/LISP}, + Type = {Research Report}, + Year = {1969}} + +@article{Hec01, + Author = {A. Heck}, + Date-Added = {2012-03-08 09:29:17 -0500}, + Date-Modified = {2012-03-08 09:30:13 -0500}, + Journal = {International Journal of Computer Algebra in Mathematics Education}, + Number = {3}, + Pages = {195-210}, + Title = {Variables in computer algebra, mathematics and science}, + Volume = {8}, + Year = {2001}} + +@techreport{GS92, + Address = {Oxford, UK}, + Author = {James Grabmeier, A. Scheerhorn}, + Date-Added = {2012-03-08 09:26:17 -0500}, + Date-Modified = {2012-03-08 09:27:51 -0500}, + Institution = {Numerical Algorithms Group}, + Keywords = {\verb|www.nag.co.uk/doc/TechRep/axiomtr.html|}, + Number = {TR7/92 (ATR/5)(NP2522)}, + Title = {Finite fields in Axiom }, + Type = {Technical Report}, + Year = {1992}} + +@article{GM94, + Author = {D. Gruntz, Michael Monagan}, + Date-Added = {2012-03-08 09:19:44 -0500}, + Date-Modified = {2012-03-08 09:24:58 -0500}, + Journal = {SIGSAM Bulletin}, + Keywords = {ISSN 0163-5824}, + Month = {August}, + Number = {3}, + Pages = {3-19}, + Title = {Introduction to Gauss}, + Volume = {28}, + Year = {1994}} + +@inproceedings{GM89, + Author = {Patrizia Gianni, T. Mora}, + Booktitle = {Applied Algebra, Algebraic Algorithms and Error-Correcting Codes}, + Date-Added = {2012-03-08 09:18:08 -0500}, + Date-Modified = {2012-03-08 09:21:55 -0500}, + Editor = {L. Huguet, A. Poli}, + Keywords = {ISBN 3-540-51082-6 LCCN QA268.A35 1987}, + Organization = {Springer-Verlag}, + Pages = {247-257}, + Publisher = {Springer-Verlag}, + Title = {Algebraic solution of systems of polynomial equations using Gr\"obner bases}, + Year = {1987}} + +@article{GM88, + Author = {R\"udiger Gebauer, H. Michael M\"oller}, + Date-Added = {2012-03-08 09:16:07 -0500}, + Date-Modified = {2012-03-08 09:17:41 -0500}, + Journal = {Journal of Symbolic Computation}, + Keywords = {ISSN 0747-7171}, + Number = {2-3}, + Pages = {275-286}, + Title = {On an installation of Buchberger's algorithm}, + Volume = {6}, + Year = {1988}} + +@inproceedings{GM86, + Address = {New York, NY 10036 USA}, + Author = {R\"udiger Gebauer, H. Michael M\"oller}, + Booktitle = {Symposium on Symbolic and Algebraic Compution}, + Date-Added = {2012-03-08 09:11:46 -0500}, + Date-Modified = {2012-03-08 09:13:28 -0500}, + Editor = {Bruce W. Char}, + Keywords = {ISBN 0-89791-199-7 LCCN QA155.7.E4.A281 1986 ACM Order Number 505860}, + Organization = {Association for Computing Machinery}, + Pages = {218-221}, + Publisher = {ACM Press}, + Title = {Buchberger's algorithm and staggered linear bases}, + Year = {1986}} + +@proceedings{SYMSAC86, + Address = {New York, NY 10036 USA}, + Date-Added = {2012-03-08 09:09:46 -0500}, + Date-Modified = {2012-03-08 09:13:33 -0500}, + Editor = {Bruce W. Char}, + Keywords = {ISBN 0-89791-199-7 LCCN QA155.7.E4.A281 1986 ACM Order Number 505860}, + Month = {July 21-23}, + Organization = {Association for Computing Machinery}, + Publisher = {ACM Press}, + Title = {Symposium on Symbolic and Algebraic Compution}, + Year = {1986}} + +@inproceedings{GL93, + Address = {Berlin, Germany}, + Author = {A. Goodloe, P. Loustaunau}, + Booktitle = {International Symposium DISCO 92}, + Date-Added = {2012-03-08 09:05:15 -0500}, + Date-Modified = {2012-03-08 09:07:39 -0500}, + Editor = {J. P. Fitch}, + Keywords = {ISBN 0-387-57272-4 LCCN QA76.9.S88I576 1992}, + Pages = {193-202}, + Publisher = {Springer-Verlag}, + Title = {An abstract data type development of graded rings}, + Year = {1992}} + +@book{GKW03, + Address = {\verb|www.springer.com/sgw/cda/frontpage/0,11855,1-102-22-1477871-0,00.html|}, + Author = {Johannes Grabmeier, Erich Kaltofen, Volker Weispfenning}, + Date-Added = {2012-03-08 09:01:55 -0500}, + Date-Modified = {2012-03-08 09:04:35 -0500}, + Keywords = {ISBN 3-540-65466-6 (637pp)}, + Publisher = {Springer-Verlag}, + Title = {Computer Algebra Handbook: Foundations, Applications, Systems}, + Year = {2003}} + +@inproceedings{GJ72b, + Author = {James H. Griesmer, Richard D. Jenks}, + Booktitle = {ACM SIGPLAN Notices (Symposium on Two-dimensional man-machine communications)}, + Date-Added = {2012-03-08 08:58:32 -0500}, + Date-Modified = {2012-03-08 09:00:07 -0500}, + Editor = {Mark B. Wells, James B Morris}, + Number = {10}, + Pages = {93-102}, + Title = {SCRATCHPAD: A capsule view}, + Volume = {7}, + Year = {1972}} + +@inproceedings{GJ72a, + Address = {Uxbridge England}, + Author = {James H. Griesmer, Richard D. Jenks}, + Booktitle = {International Conference on Online Interactive Computing}, + Date-Added = {2012-03-08 08:56:01 -0500}, + Date-Modified = {2012-03-08 08:58:05 -0500}, + Keywords = {ISBN 0-903796-02-3 LCCN QA76.55.O54 1972 (2 volumes)}, + Month = {September 4-7}, + Organization = {Brunel University}, + Title = {Experience with an online symbolic math system SCRATCHPAD}, + Year = {1972}} + +@proceedings{Onl72, + Address = {Uxbridge England}, + Date-Added = {2012-03-08 08:53:42 -0500}, + Date-Modified = {2012-03-08 08:58:03 -0500}, + Keywords = {ISBN 0-903796-02-3 LCCN QA76.55.O54 1972 (2 volumes)}, + Month = {September 4-7}, + Organization = {Brunel University}, + Title = {International Conference on Online Interactive Computing}, + Year = {1972}} + +@inproceedings{GJ71, + Address = {\verb|delivery.acm.org/10.1145/810000/806266/p42-griesmer.pdf|}, + Author = {James H. Griesmer, Richard D. Jenks}, + Booktitle = {Symbolic and Algebraic Manipulation}, + Date-Added = {2012-03-08 08:49:56 -0500}, + Date-Modified = {2012-03-08 08:52:48 -0500}, + Editor = {S. R. Petric}, + Keywords = {LCCN QA76.5.S94 1971}, + Organization = {Association for Computing Machinery}, + Pages = {42-58}, + Publisher = {ACM Press}, + Title = {SCRATCHPAD/1 -- an interactive facility for symbolic mathematics}, + Year = {1971}} + +@proceedings{Pet71, + Address = {New York, NY 10036 USA}, + Date-Added = {2012-03-08 08:48:14 -0500}, + Date-Modified = {2012-03-08 08:52:50 -0500}, + Editor = {S. R. Petric}, + Keywords = {LCCN QA76.5.S94 1971}, + Month = {March 23-25}, + Organization = {Association for Computing Machinery}, + Publisher = {ACM Press}, + Title = {Symbolic and Algebraic Manipulation}, + Year = {1971}} + +@techreport{GHK91, + Address = {Heidelberg, Germany}, + Author = {James Grabmeier, K. Huber, U. Krieger}, + Date-Added = {2012-03-08 08:45:32 -0500}, + Date-Modified = {2012-03-08 08:47:47 -0500}, + Institution = {IBM Wissenschaftliches Zentrum}, + Number = {TR 75.91.20}, + Title = {Das ComputeralgebraSystem AXIOM bei krytologischen und verkehrstheoretischen Untersuchungen des Forschunginstituts der Deutschen Bundespost TELEKOM}, + Type = {Technical Report}, + Year = {1991}} + +@inproceedings{BHGM04, + Author = {Richard Boulton, Ruth Hardy, Hanne Gottliebsen, Ursula Martin}, + Booktitle = {Fourth International Conference on Integrated Formal Methods}, + Date-Added = {2012-03-08 08:43:26 -0500}, + Date-Modified = {2012-03-08 08:45:13 -0500}, + Month = {April}, + Title = {Design verification for control engineering}, + Year = {2004}} + +@inproceedings{GBL91, + Address = {Washington, DC, USA}, + Author = {B. M. Goodwin, R. A. Buonopane, A. Lee}, + Booktitle = {Challenges of a Changing World}, + Date-Added = {2012-03-07 07:33:37 -0500}, + Date-Modified = {2012-03-07 07:35:49 -0500}, + Organization = {American Society for Engineering Education}, + Pages = {345-349}, + Title = {Using MathCAD in teaching material and energy balance concepts}, + Volume = {1}, + Year = {1991}} + +@techreport{Fou90, + Address = {Strasbourg, France}, + Author = {Francois Fouche}, + Date-Added = {2012-03-07 07:31:00 -0500}, + Date-Modified = {2012-03-07 07:32:37 -0500}, + Institution = {Institut de Recherche Math\'ematique Avanc\'ee }, + Keywords = {31pp}, + Title = {Une implantation de l'algorithme de Kovacic en Scratchpad}, + Type = {Technical Report}, + Year = {1990}} + +@book{Wes99, + Author = {Michael J. Wester}, + Date-Added = {2012-03-07 07:29:06 -0500}, + Date-Modified = {2012-03-07 07:30:01 -0500}, + Keywords = {ISBN 0-471-98353-5}, + Publisher = {John Wiley and Sons}, + Title = {Computer Algebra Systems}, + Year = {1999}} + +@misc{WJ12, + Author = {Wei-Jiang}, + Date-Added = {2012-03-07 07:28:00 -0500}, + Date-Modified = {2012-03-07 07:28:50 -0500}, + Howpublished = {\verb|wei-jiang.com/it/software/top-free-algebra-system-bye-mathematics-bye-maple|}, + Title = {Top free algebra system}} + +@misc{Wiki2, + Date-Added = {2012-03-07 07:24:41 -0500}, + Date-Modified = {2012-03-07 07:27:05 -0500}, + Howpublished = {\verb|en.wikipedia.org/wiki/Comparison_of_computer_algebra_systems|}, + Title = {Comparison of computer algebra systems}} + +@misc{Wiki1, + Author = {Timothy Daly}, + Date-Added = {2012-03-07 07:23:41 -0500}, + Date-Modified = {2012-03-07 07:24:27 -0500}, + Howpublished = {\verb|en.wikipedia.org/wiki/Axiom_computer_algebra_system|}, + Title = {Axiom (computer algebra system)}} + +@misc{Wat95, + Author = {Stephen M. Watt}, + Date-Added = {2012-03-07 07:20:26 -0500}, + Date-Modified = {2012-03-07 07:20:59 -0500}, + Howpublished = {NAG Ltd}, + Title = {AXIOM Library Compiler Users Guide}, + Year = {1995}} + +@misc{Wat94a, + Author = {Stephen M. Watt}, + Date-Added = {2012-03-07 07:19:30 -0500}, + Date-Modified = {2012-03-07 07:20:21 -0500}, + Month = {June 8}, + Title = {A\# User's Guide Version 1.0.0 O($\epsilon{}^1$)}, + Year = {1994}} + +@misc{Seiler, + Author = {Werner M. Seiler}, + Date-Added = {2012-03-07 07:17:59 -0500}, + Date-Modified = {2012-03-07 07:18:52 -0500}, + Howpublished = {\verb|iaks-www.ira.uka.de/iaks-calmet/werner/werner.html|}, + Title = {DETools: A LIbrary for Differential Equations}} + +@misc{OpenMa, + Date-Added = {2012-03-07 07:17:06 -0500}, + Date-Modified = {2012-03-07 07:17:29 -0500}, + Howpublished = {\verb|www.openmath.org/overview/technical.html|}, + Title = {OpenMath Technical Overview}} + +@misc{McJ11, + Author = {Paul McJones}, + Date-Added = {2012-03-07 07:16:06 -0500}, + Date-Modified = {2012-03-07 07:16:52 -0500}, + Howpublished = {\verb|www.softwarepreservation.org/projects/LISP/common_lisp_family|}, + Title = {Software Presentation Group -- Common Lisp family}} + +@misc{Lin93, + Author = {Steve Linton}, + Date-Added = {2012-03-07 07:15:00 -0500}, + Date-Modified = {2012-03-07 07:15:51 -0500}, + Howpublished = {\verb|www.cs.st-andrews.ac.uk/~sal/nme/nme_toc.html#SEC1|}, + Title = {Vector Enumeration Programs, version 3.04}} + +@misc{Lah08, + Author = {Tim Lahey}, + Date-Added = {2012-03-07 07:14:06 -0500}, + Date-Modified = {2012-03-07 07:14:42 -0500}, + Howpublished = {\verb|github.com/tjl/sage_int_testing|}, + Month = {December}, + Title = {Sage Integration Testing}, + Year = {2008}} + +@misc{Ken99b, + Author = {W. S. Kendall}, + Date-Added = {2012-03-07 07:12:59 -0500}, + Date-Modified = {2012-03-07 07:13:54 -0500}, + Howpublished = {\verb|www2.warwick.ac.uk/fac/sci/statistics/staff/academic-research/kendall/personal/ppt/327.ps.gz|}, + Title = {Symbolic Ito calculus in AXIOM: an ongoing story}} + +@misc{Ken99a, + Author = {W. S. Kendall}, + Date-Added = {2012-03-07 07:11:29 -0500}, + Date-Modified = {2012-03-07 07:12:41 -0500}, + Howpublished = {\verb|www2.warwick.ac.uk/fac/sci/statistics/staff/academic-research/kendall/personal/ppt/328.ps.gz|}, + Title = {Itovsn3 in AXIOM: modules, algebras and stochastic differentials}} + +@book{JT03, + Address = {Berlin, Germany}, + Author = {Michael Joswig, Nobuki Takayama}, + Date-Added = {2012-03-07 07:09:59 -0500}, + Date-Modified = {2012-03-07 07:11:08 -0500}, + Keywords = {ISBN 3-540-00256-1 (p291)}, + Publisher = {Springer-Verlag}, + Title = {Algebra, geometry, and software systems}} + +@misc{Kel00b, + Author = {Tom Kelsey}, + Date-Added = {2012-03-07 07:08:49 -0500}, + Date-Modified = {2012-03-07 07:09:43 -0500}, + Howpublished = {\verb|www.cs.st-andrews.cs.uk/~tom/pub/fscbstalk.ps|}, + Keywords = {University of St. Andrews}, + Month = {September}, + Title = {Formal specification of computer algebra (slides)}, + Year = {2000}} + +@misc{Kel00a, + Author = {Tom Kelsey}, + Date-Added = {2012-03-07 07:07:20 -0500}, + Date-Modified = {2012-03-07 07:08:43 -0500}, + Howpublished = {\verb|www.cs.st-andrews.cs.uk/~tom/pub/fscbs.ps|}, + Keywords = {University of St. Andrews}, + Month = {April 6}, + Title = {Formal specification of computer algebra}, + Year = {2000}} + +@periodical{Jo06, + Author = {David Joyner}, + Date-Added = {2012-03-07 07:05:06 -0500}, + Date-Modified = {2012-03-07 07:06:32 -0500}, + Howpublished = {\verb|sage.math.washington.edu/home/wdj/sigsam/oscas-cca1.pdf|}, + Journal = {SIGSAM Commications in Computer Algebra}, + Title = {OSCAS - Maxima}, + Volume = {157}, + Year = {2006}} + +@misc{Jen88, + Author = {Richard D. Jenks}, + Date-Added = {2012-03-07 07:04:18 -0500}, + Date-Modified = {2012-03-07 07:04:55 -0500}, + Month = {Spring}, + Title = {The Scratchpad II Computer Algebra System Interactive Environment Users Guide}, + Year = {1988}} + +@misc{Jen88, + Author = {Richard D. Jenks}, + Date-Added = {2012-03-07 07:02:39 -0500}, + Date-Modified = {2012-03-07 07:04:04 -0500}, + Howpublished = {\verb|daly.axiom-developer.org/boot.tgz|}, + Keywords = {draft}, + Month = {September 5}, + Title = {A Guide to Programming in BOOT}, + Year = {1988}} + +@misc{GJY75, + Author = {James H. Griesmer, Richard D. Jenks, David Y. Y. Yun}, + Date-Added = {2012-03-07 07:00:40 -0500}, + Date-Modified = {2012-03-07 07:01:47 -0500}, + Howpublished = {IBM Research Publication RA70}, + Month = {June}, + Title = {SCRATCHPAD User's Manual}, + Year = {1975}} + +@misc{Gon96, + Author = {Gaston H. Gonnet}, + Date-Added = {2012-03-07 06:59:53 -0500}, + Date-Modified = {2012-03-07 07:00:28 -0500}, + Howpublished = {\verb|www.inf.ethz.ch/personal/gonnet/ContDict/Meta|}, + Title = {Official version 1.0 of the Meta Content Dictionary}} + +@misc{Fris, + Date-Added = {2012-03-07 06:59:13 -0500}, + Date-Modified = {2012-03-07 06:59:44 -0500}, + Howpublished = {\verb|www.nag.co.uk/projects/frisco/frisco/node3.html|}, + Title = {Objective and Results}} + +@misc{Fog11, + Author = {Michael Fogus}, + Date-Added = {2012-03-07 06:58:14 -0500}, + Date-Modified = {2012-03-07 06:59:05 -0500}, + Howpublished = {\verb|clojure.com/blog/2011/11/22/unconj.html|}, + Month = {August}, + Title = {UnConj}, + Year = {2011}} + +@article{GKM05, + Author = {Hanne Gottliebsen, Tom Kelsey, Ursula Martin}, + Date-Added = {2012-03-07 06:56:33 -0500}, + Date-Modified = {2012-03-07 06:57:42 -0500}, + Journal = {Journal of Symbolic Computation}, + Number = {5}, + Title = {Hidden verification for computational mathematics}, + Volume = {39}, + Year = {2005}} + +@book{GCL92, + Author = {Keith O. Geddes, Stephen R. Czapor, George Labahn}, + Date-Added = {2012-03-07 06:54:46 -0500}, + Date-Modified = {2012-03-07 06:56:16 -0500}, + Keywords = {ISBN 0-7923-9259-0}, + Month = {September}, + Publisher = {Kluwer Academic Publishers}, + Title = {Algorithms For Computer Algebra}, + Year = {1992}} + +@techreport{Wat94, + Address = {Yorktown Heights, NY}, + Author = {Stephen M. Watt, Peter A. Broadbery, Samuel S. Dooley, Pietro Iglio}, + Date-Added = {2012-03-07 06:52:07 -0500}, + Date-Modified = {2012-03-07 06:53:34 -0500}, + Institution = {IBM Thomas J. Watson Research Center}, + Number = {RC19529 (85075)}, + Title = {A First Report on the A\# Compiler (including benchmarks)}, + Year = {1994}} + +@techreport{SJ87c, + Address = {Yorktown Heights, NY}, + Author = {Robert S. Sutor, Richard D. Jenks}, + Date-Added = {2012-03-07 06:28:40 -0500}, + Date-Modified = {2012-03-07 06:30:02 -0500}, + Institution = {IBM Thomas J. Watson Research Center}, + Number = {RC12595 (56575)}, + Title = {The type inference and coercion facilities in the Scratchpad II interpreter}, + Year = {1987}} + +@techreport{Nor75a, + Author = {Arthur C. Norman}, + Date-Added = {2012-03-07 06:27:18 -0500}, + Date-Modified = {2012-03-07 06:28:00 -0500}, + Institution = {IBM Thomas J. Watson Research Center}, + Number = {RC4998}, + Title = {The SCRATCHPAD Power Series Package}} + +@techreport{Jen71, + Address = {Yorktown Heights, NY}, + Author = {Richard D. Jenks}, + Date-Added = {2012-03-07 06:26:15 -0500}, + Date-Modified = {2012-03-07 06:27:02 -0500}, + Institution = {IBM Thomas J. Watson Research Center}, + Number = {RC3259}, + Title = {META/PLUS: The syntax extension facility for SCRATCHPAD}, + Year = {1971}} + +@techreport{JT81b, + Address = {Yorktown Heights, NY}, + Author = {Richard D. Jenks, Barry M. Trager}, + Date-Added = {2012-03-07 06:24:09 -0500}, + Date-Modified = {2012-03-07 06:25:25 -0500}, + Institution = {IBM Thomas J. Watson Research Center}, + Number = {RC8930}, + Title = {A Language for Computational Algebra}} + +@techreport{JWS86, + Address = {Yorktown Heights, NY }, + Author = {Richard D. Jenks, Robert S. Sutor, Stephen M. Watt}, + Date-Added = {2012-03-07 06:10:33 -0500}, + Date-Modified = {2012-03-07 06:13:04 -0500}, + Institution = {IBM Thomas J. Watson Research Center}, + Number = {RC 12327 (55257)}, + Title = {Scratchpad II: an abstract datatype system for mathematical computation}, + Type = {Technical Report}, + Year = {1986}} + +@book{JS92, + Author = {Richard D. Jenks, Robert S. Sutor}, + Date-Added = {2012-03-07 06:03:55 -0500}, + Date-Modified = {2012-03-07 06:05:38 -0500}, + Keywords = {ISBN 0-387-97855-0 LCCN QA76.95.J46 1992 (742pp)}, + Publisher = {Springer-Verlag}, + Title = {AXIOM: The Scientific Computation System}, + Year = {1992}} + +@inproceedings{Jen76, + Address = {New York, NY 10036 USA}, + Author = {Richard D. Jenks}, + Booktitle = {Symposium on Symbolic and Algebraic Compution}, + Date-Added = {2012-03-07 05:50:02 -0500}, + Date-Modified = {2012-03-07 05:51:25 -0500}, + Editor = {Richard D. Jenks}, + Keywords = {LCCN QS155.7.EA.A15 1976 QA9.58.A11 1976}, + Organization = {Association for Computing Machinery}, + Pages = {60-65}, + Publisher = {ACM Press}, + Title = {A pattern compiler}, + Year = {1976}} + +@proceedings{SYMSAC76, + Address = {New York, NY 10036 USA}, + Date-Added = {2012-03-07 05:48:14 -0500}, + Date-Modified = {2012-03-07 05:50:14 -0500}, + Editor = {Richard D. Jenks}, + Keywords = {LCCN QS155.7.EA.A15 1976 QA9.58.A11 1976}, + Organization = {Association for Computing Machinery}, + Publisher = {ACM Press}, + Title = {Symposium on Symbolic and Algebraic Compution}, + Year = {1976}} + +@proceedings{HP89, + Address = {Berlin, Germany}, + Booktitle = {5th International Conference AAECC-5}, + Date-Added = {2012-03-07 05:46:15 -0500}, + Date-Modified = {2012-03-08 09:20:44 -0500}, + Editor = {L. Huguet, A. Poli}, + Keywords = {ISBN 3-540-51082-6 LCCN QA268.A35 1987}, + Organization = {Springer-Verlag}, + Publisher = {Springer-Verlag}, + Title = {Applied Algebra, Algebraic Algorithms and Error-Correcting Codes}, + Year = {1987}} + +@proceedings{AAECC5, + Address = {Berlin, Germany}, + Date-Added = {2012-03-07 05:43:57 -0500}, + Date-Modified = {2012-03-07 05:47:54 -0500}, + Editor = {L. Huguet, A. Poli}, + Keywords = {ISBN 3-540-51082-6 LCCN QA268.A35 1987}, + Organization = {Springer-Verlag}, + Publisher = {Springer-Verlag}, + Title = {5th International Conference AAECC-5}, + Year = {1987}} + +@proceedings{Fit93, + Address = {Berlin, Germany}, + Date-Added = {2012-03-07 05:41:41 -0500}, + Date-Modified = {2012-03-07 05:43:04 -0500}, + Editor = {J. P. Fitch}, + Keywords = {ISBN 0-387-57272-4 LCCN QA76.9.S88I576 1992}, + Organization = {Springer-Verlag}, + Publisher = {Springer-Verlag}, + Title = {International Symposium DISCO 92}, + Year = {1992}} + +@proceedings{Fit84, + Date-Added = {2012-03-07 05:40:02 -0500}, + Date-Modified = {2012-03-07 05:41:29 -0500}, + Editor = {J. P. Fitch}, + Keywords = {ISBN 0-387-13350-X LCCN QA155.7.E4.I57 1984}, + Month = {July 9-11}, + Organization = {Springer-Verlag}, + Publisher = {Springer-Verlag}, + Title = {International Symposium on Symbolic and Algebraic Computation}, + Volume = {174 of Lecture Notes in Computer Science}, + Year = {1984}} + +@techreport{FDN00, + Author = {Christ\'ele Faure, James H. Davenport, Hanane Naciri}, + Date-Added = {2012-03-07 05:37:45 -0500}, + Date-Modified = {2012-03-07 05:39:50 -0500}, + Institution = {Institut National de Recherche en Informatique et en Automatique}, + Keywords = {ISSN 0249-6399}, + Number = {4001}, + Title = {Multi-values Computer Algebra}, + Year = {2000}} + +@misc{FD, + Author = {Christ\'ele Faure, James H. Davenport}, + Date-Added = {2012-03-07 05:36:41 -0500}, + Date-Modified = {2012-03-07 05:37:26 -0500}, + Title = {Parameters in Computer Algebra}} + +@misc{Fat05, + Author = {Richard J. Fateman}, + Date-Added = {2012-03-07 05:35:33 -0500}, + Date-Modified = {2012-03-07 05:36:35 -0500}, + Howpublished = {\verb|www.cs.berkeley.edu/~fateman/papers/axiom.pdf|}, + Month = {April 19}, + Title = {An incremental approach to building a mathematical expert out of software}, + Year = {2005}} + +@inproceedings{Fat90, + Address = {New York, NY 10036 USA}, + Author = {Richard J. Fateman}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-07 05:33:37 -0500}, + Date-Modified = {2012-03-07 05:35:14 -0500}, + Editor = {Shunro Watanabe, Morio Nagata}, + Keywords = {ISBN 0-89791-401-5 LCCN QA76.95.I57 1990}, + Organization = {Association for Computing Machinery}, + Pages = {60-67}, + Publisher = {ACM Press}, + Title = {Advances and trends in the design and construction of algebraic manipulation systmes}, + Year = {1990}} + +@proceedings{WN90, + Address = {New York, NY 10036 USA}, + Date-Added = {2012-03-07 05:31:47 -0500}, + Date-Modified = {2012-03-07 05:33:52 -0500}, + Editor = {Shunro Watanabe, Morio Nagata}, + Keywords = {ISBN 0-89791-401-5 LCCN QA76.95.I57 1990}, + Organization = {Association for Computing Machinery}, + Publisher = {ACM Press}, + Title = {International Symposium on Symbolic and Algebraic Computation}, + Year = {1990}} + +@misc{ES10, + Author = {Burcin Er\"ocal, William Stein}, + Date-Added = {2012-03-07 05:30:34 -0500}, + Date-Modified = {2012-03-07 05:31:28 -0500}, + Howpublished = {\verb|wstein.org/papers/icms/icms_2010.pdf|}, + Title = {The Sage Project}} + +@article{Du95, + Author = {D. Duval}, + Date-Added = {2012-03-07 05:29:19 -0500}, + Date-Modified = {2012-03-07 05:30:27 -0500}, + Journal = {Journal of Pure and Applied Algebra}, + Number = {99}, + Pages = {267-295}, + Title = {Evaluation dynamique et cl\^oture alg\'ebrique en Axiom}, + Year = {1995}} + +@article{DGKM01a, + Author = {Martin Dunstan, Hanne Gottliebsen, Tom Kelsey, Ursula Martin}, + Date-Added = {2012-03-07 04:26:48 -0500}, + Date-Modified = {2012-03-07 04:28:00 -0500}, + Journal = {Calculemus 2001}, + Keywords = {\verb|www.cs.st-andrews.ac.uk/~tom/pub/dunstanetal.ps|}, + Title = {Computer Algebra meets Automated Theorem Proving: A Maple-PVS Interface}, + Year = {2001}} + +@article{DGKM01, + Author = {Martin Dunstan, Hanne Gottliebsen, Tom Kelsey, Ursula Martin}, + Date-Added = {2012-03-07 04:24:38 -0500}, + Date-Modified = {2012-03-07 04:26:14 -0500}, + Journal = {TPHOLS 2001}, + Keywords = {\verb|www.cs.st-andrews.ac.uk/~tom/pub/tphols.ps|}, + Title = {Comptuer Algebra meets Automated Theorem Proving: A Maple-PVS Interface}, + Year = {2001}} + +@phdthesis{Dun99a, + Address = {\verb|www.cs.st-andrews.uk/files/publications/Dun99.php|}, + Author = {Martin Dunstan}, + Date-Added = {2012-03-07 04:22:27 -0500}, + Date-Modified = {2012-03-07 04:24:16 -0500}, + Keywords = {\verb|axiom-portal.newsynthesis.org/refs/articles/mnd-sep99-thesis.pdf|}, + School = {University of St Andrews}, + Title = {Larch/Aldor - A Larch BISL for AXIOM and Aldor}, + Type = {Ph.D. thesis}, + Year = {1999}} + +@article{Dun99, + Author = {Martin Dunstan, Tom Kelsey, Steve Linton, Ursula Martin}, + Date-Added = {2012-03-07 04:20:59 -0500}, + Date-Modified = {2012-03-07 04:22:14 -0500}, + Journal = {FM 99}, + Month = {Sept 20-24}, + Pages = {1758-1777}, + Title = {Formal Methods for Extensions to CAS}, + Year = {1999}} + +@techreport{Dun97, + Address = {\verb|www.cs.st-andrews.ac.uk/research/output/detail?output=ML97.php|}, + Author = {Martin Dunstan, Steve Linton, Ursula Martin}, + Date-Added = {2012-03-07 04:16:51 -0500}, + Date-Modified = {2012-03-07 04:19:50 -0500}, + Institution = {University of St Andrews}, + Month = {November 1 - February 28}, + Number = {GR/L48256}, + Title = {Embedded Verification Techniques for Computer Algebra Systems}, + Type = {Grant citation}, + Year = {1997-2001}} + +@inproceedings{Dun98, + Author = {Martin Dunstan, Tom Kelsey, Steve Linton, Ursula Martin}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-07 04:14:56 -0500}, + Date-Modified = {2012-03-07 04:16:35 -0500}, + Keywords = {\verb|www.cs.st-andrews.ac.uk/~tom/pub/issac98.pdf|}, + Title = {Lightweight Formal Methods for Computer Algebra Systems}, + Year = {1998}} + +@techreport{DT92, + Address = {Oxford, UK}, + Author = {James H. Davenport, Barry M. Trager}, + Date-Added = {2012-03-07 04:13:09 -0500}, + Date-Modified = {2012-03-07 04:14:24 -0500}, + Institution = {Numerical Algorithms Group}, + Keywords = {\verb|www.nag.co.uk/doc/TechRep/axiomtr.html|}, + Month = {December}, + Number = {TR3/92 (ATR/1)(NP2490)}, + Title = {Scratchpad's view of algebra I: Basic commutative algebra}, + Type = {Technical Report}, + Year = {1992}} + +@inproceedings{For90, + Author = {A. Fortenbacher}, + Booktitle = {International Symposium DISCO 90}, + Date-Added = {2012-03-07 04:10:41 -0500}, + Date-Modified = {2012-03-07 04:12:04 -0500}, + Editor = {A. Miola}, + Keywords = {ISBN 0-387-52531-9 LCCN QA76.9.S88I576 1990}, + Month = {April 10-12}, + Organization = {Springer-Verlag}, + Pages = {56-60}, + Publisher = {Springer-Verlag}, + Title = {Efficient type inference and coercion in computer algebra}, + Year = {1990}} + +@inproceedings{DT90, + Author = {James H. Davenport, Barry M. Trager}, + Booktitle = {International Symposium DISCO 90}, + Date-Added = {2012-03-07 04:08:49 -0500}, + Date-Modified = {2012-03-07 04:10:28 -0500}, + Editor = {A. Miola}, + Keywords = {ISBN 0-387-52531-9 LCCN QA76.9.S88I576 1990}, + Pages = {40-54}, + Title = {Scratchpad's view of algebra I: Basic commutative algebra}, + Year = {1990}} + +@proceedings{Mio90, + Address = {Berlin, Germany}, + Date-Added = {2012-03-07 04:05:32 -0500}, + Date-Modified = {2012-03-07 04:12:18 -0500}, + Editor = {A. Miola}, + Keywords = {ISBN 0-387-52531-9 LCCN QA76.9.S88I576 1990}, + Month = {April 10-12}, + Organization = {Springer-Verlag}, + Publisher = {Springer-Verlag}, + Title = {International Symposium DISCO 90}, + Volume = {429 of Lecture Notes in Computer Science}, + Year = {1990}} + +@book{DST88, + Author = {James H. Davenport, Y. Siret, E. Tournier}, + Date-Added = {2012-03-07 04:03:41 -0500}, + Date-Modified = {2012-03-07 04:05:03 -0500}, + Keywords = {ISBN 0-12-204232-9}, + Publisher = {Academic Press}, + Title = {Computer Algebra: Systems and Algorithms for Algebraic Computation}, + Year = {1988}} + +@inproceedings{Doy99, + Address = {\verb|www.acm.org/pubs/contents/proceedings/issac/309831|}, + Author = {Nicolas J. Doye}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-07 04:00:22 -0500}, + Date-Modified = {2012-03-07 04:02:50 -0500}, + Editor = {Sam Dooley}, + Keywords = {ISBN 1-58113-073-2 LCCN QA76.95.I57 1999}, + Month = {July 29-31}, + Organization = {Simon Fraser University}, + Pages = {229-235}, + Publisher = {ACM Press}, + Title = {Automated coercion for Axiom}, + Year = {1999}} + +@misc{DLMF, + Date-Added = {2012-03-07 03:57:40 -0500}, + Date-Modified = {2012-03-07 03:59:15 -0500}, + Howpublished = {\verb|dlmf.nist.gov/help/cite|}, + Month = {August 29}, + Title = {Digital Library of Mathematical Functions}, + Year = {2011}} + +@proceedings{Doo99, + Address = {\verb|www.acm.org/pubs/contents/proceedings/issac/309831|}, + Date-Added = {2012-03-07 03:55:03 -0500}, + Date-Modified = {2012-03-07 04:03:09 -0500}, + Editor = {Sam Dooley}, + Keywords = {ISBN 1-58113-073-2 LCCN QA76.95.I57 1999}, + Month = {July 29-31}, + Organization = {Simon Fraser University}, + Publisher = {ACM Press}, + Title = {International Symposium on Symbolic and Algebraic Computation}, + Year = {1999}} + +@periodical{DJ92, + Author = {D Duval, F. Jung}, + Date-Added = {2012-03-07 03:53:20 -0500}, + Date-Modified = {2012-03-07 03:54:41 -0500}, + Journal = {IFIP Transactions Computer Science and Technology}, + Keywords = {ISSN 0926-5473}, + Pages = {133-141}, + Title = {Examples of problem solving using computer algebra}, + Volume = {143}, + Year = {1992}} + +@misc{DGW, + Author = {Stephane Dalman, Marc Gaetano, Stephen Watt}, + Date-Added = {2012-03-07 03:51:39 -0500}, + Date-Modified = {2012-03-07 03:52:46 -0500}, + Howpublished = {\verb|citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.116.4401.pdf|}, + Title = {An OpenMath 1.0 Implementation}} + +@techreport{DGT92, + Address = {Oxford, UK}, + Author = {James H. Davenport, Patrizia Gianni, Barry M. Trager}, + Date-Added = {2012-03-07 03:49:29 -0500}, + Date-Modified = {2012-03-07 03:51:27 -0500}, + Institution = {Numerical Algorithms Group}, + Keywords = {\verb|www.nag.co.uk/doc/TechRep/axiomtr.html|}, + Month = {December}, + Number = {TR4/92 (ATR/2) (NP2491)}, + Title = {Scratchpad's view of algebra II: A categorical view of factorization}, + Type = {Technical Report}, + Year = {1992}} + +@techreport{DGJ84, + Author = {James Davenport, Patrizia Gianni, Richard Jenks, Victor Miller, Scott Morrison, Michael Rothstein, Christine Sundaresan, Robert Sutor, Barry Trager}, + Date-Added = {2012-03-07 03:47:46 -0500}, + Date-Modified = {2012-03-07 03:49:19 -0500}, + Institution = {IBM Thomas J. Watson Research Center}, + Title = {Scratchpad}, + Year = {1984}} + +@misc{Dew, + Author = {Mike Dewar}, + Date-Added = {2012-03-07 03:46:44 -0500}, + Date-Modified = {2012-03-07 03:47:22 -0500}, + Howpublished = {\verb|www.sigsam.org/bulletin/articles/132/paper1.pdf|}, + Title = {OpenMath: An Overview}} + +@inproceedings{Dew94, + Address = {Helsinki, Finland}, + Author = {M. C. Dewar}, + Booktitle = {Workshop on Symbolic and Numeric Computing}, + Date-Added = {2012-03-07 03:44:54 -0500}, + Date-Modified = {2012-03-07 03:46:20 -0500}, + Editor = {H. Apiola, M. Laine, E. Valkeila}, + Organization = {University of Helsinki}, + Pages = {1-12}, + Title = {Manipulating Fortran Code in AXIOM and the AXIOM-NAG Link}, + Year = {1994}} + +@proceedings{WSNC94, + Address = {Helsinki, Finland}, + Date-Added = {2012-03-07 03:43:17 -0500}, + Date-Modified = {2012-03-07 03:44:50 -0500}, + Editor = {H. Apiola, M. Laine, E. Valkeila}, + Organization = {University of Helsinki}, + Title = {Workshop on Symbolic and Numeric Computing}, + Year = {1994}} + +@inproceedings{Dev93, + Author = {R. G. E. Pinch}, + Booktitle = {Computers and Mathematics}, + Date-Added = {2012-03-07 03:40:56 -0500}, + Date-Modified = {2012-03-07 03:42:53 -0500}, + Editor = {Keith Devlin}, + Number = {9}, + Pages = {1203-1210}, + Title = {Some Primality Testing Algorithms}, + Volume = {40}, + Year = {1993}} + +@inproceedings{Wat88, + Address = {Berlin, Germany}, + Author = {Stephen M. Watt}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-07 03:36:14 -0500}, + Date-Modified = {2012-03-07 03:38:01 -0500}, + Editor = {Patrizia Gianni}, + Keywords = {ISBN 3-540-51084-2 LCCN QA76.95.I57 1988}, + Month = {July 4-8}, + Organization = {Springer-Verlag}, + Pages = {206-217}, + Publisher = {Springer-Verlag}, + Title = {A fixed point method for power series computation}, + Year = {1988}} + +@inproceedings{DD89, + Address = {Berlin, Germany}, + Author = {C. Dicrescenzo, D. Duval}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-06 14:30:40 -0500}, + Date-Modified = {2012-03-07 03:36:01 -0500}, + Editor = {Patrizia Gianni}, + Keywords = {ISBN 3-540-51084-2 LCCN QA76.95.I57 1988}, + Organization = {Springer-Verlag}, + Pages = {440-446}, + Publisher = {Springer-Verlag}, + Title = {Algebraic extensions and algebraic closure in Scratchpad II}, + Year = {1988}} + +@proceedings{Gia88, + Address = {Berlin, Germany}, + Date-Added = {2012-03-06 14:28:07 -0500}, + Date-Modified = {2012-03-07 03:38:12 -0500}, + Editor = {Patrizia Gianni}, + Keywords = {ISBN 3-540-51084-2 LCCN QA76.95.I57 1988}, + Month = {July 4-8}, + Organization = {Springer-Verlag}, + Publisher = {Springer-Verlag}, + Title = {International Symposium on Symbolic and Algebraic Computation}, + Volume = {358 of Lecture Notes in Computer Science}, + Year = {1988}} + +@unpublished{DSTxx, + Author = {James H. Davenport, Siret, Tournier}, + Date-Added = {2012-03-06 14:25:15 -0500}, + Date-Modified = {2012-03-06 14:26:40 -0500}, + Keywords = {\verb|staff.bath.ac.uk/masjhd/masternew.pdf|}, + Note = {book}, + Title = {Computer Algebra}} + +@unpublished{Dav10, + Author = {James H. Davenport}, + Date-Added = {2012-03-06 14:23:58 -0500}, + Date-Modified = {2012-03-06 14:25:01 -0500}, + Keywords = {\verb|staff.bath.ac.uk/masjhd/JHD-CA.pdf|}, + Note = {book}, + Title = {Computer Algebra}} + +@url{Dav00, + Author = {James H. Davenport}, + Date-Added = {2012-03-06 14:22:54 -0500}, + Date-Modified = {2012-03-06 14:23:31 -0500}, + Title = {13th OpenMath Meeting}, + Urldate = {\verb|xml.coverpages.org/openmath13.html|}} + +@techreport{Dav93, + Address = {Oxford, UK}, + Author = {James H. Davenport}, + Date-Added = {2012-03-06 14:21:24 -0500}, + Date-Modified = {2012-03-06 14:22:40 -0500}, + Institution = {Numerical Algorithms Group}, + Keywords = {\verb|www.nag.co.uk/doc/TechRep/axiomtr.html|}, + Month = {August}, + Number = {TR2/93 (ATR/6) (NP2556)}, + Title = {Primality testing revisited}, + Type = {Technical Report}, + Year = {1993}} + +@techreport{Dav92b, + Address = {Oxford, UK}, + Author = {James H. Davenport}, + Date-Added = {2012-03-06 14:19:06 -0500}, + Date-Modified = {2012-03-06 14:20:17 -0500}, + Institution = {Numerical Algorithms Group}, + Keywords = {\verb|www.nag.co.uk/doc/TechRep/axiomtr.html|}, + Month = {December}, + Number = {TR6/92 (ATR/4)}, + Title = {How does one program in the AXIOM system}, + Type = {Technical Report}, + Year = {1992}} + +@techreport{Dav92a, + Address = {Oxford, UK}, + Author = {James H. Davenport}, + Date-Added = {2012-03-06 14:17:00 -0500}, + Date-Modified = {2012-03-06 14:18:52 -0500}, + Institution = {Numerical Algorithms Group}, + Keywords = {\verb|www.nag.co.uk/doc/TechRep/axiomtr.html|}, + Month = {December}, + Number = {TR5/92 (ATR/3)}, + Title = {The Axiom system}, + Type = {AXIOM Technical Report}, + Year = {1992}} + +@article{Dav85, + Author = {James H. Davenport}, + Date-Added = {2012-03-06 14:15:25 -0500}, + Date-Modified = {2012-03-06 14:16:47 -0500}, + Journal = {The Scratchpad II Newsletter}, + Keywords = {IBM Corporation, Yorktown Heights, NY}, + Month = {September 1}, + Number = {1}, + Title = {The LISP/VM Foundation of Scratchpad II}, + Volume = {1}, + Year = {1985}} + +@article{Dav82b, + Author = {James H. Davenport}, + Date-Added = {2012-03-06 14:04:49 -0500}, + Date-Modified = {2012-03-06 14:14:02 -0500}, + Journal = {Proceedings of EUROCAM 82}, + Number = {LNCS 144}, + Pages = {145-157}, + Title = {On the Parallel Risch Algorithm (i)}, + Year = {1982}} + +@article{DT85, + Author = {James H. Davenport, Barry M. Trager}, + Date-Added = {2012-03-06 14:00:36 -0500}, + Date-Modified = {2012-03-06 14:13:35 -0500}, + Journal = {ACM Transactions on Mathematical Software}, + Keywords = {DOI doi.acm.org/10.1145/6187.6189 ISSN 0098-3500}, + Month = {December}, + Number = {4}, + Pages = {356-362}, + Title = {On the parallel Risch Algorithm (II)}, + Volume = {11}, + Year = {Dec, 1985}} + +@article{Dav82, + Author = {James H. Davenport}, + Date-Added = {2012-03-06 13:58:30 -0500}, + Date-Modified = {2012-03-06 14:12:29 -0500}, + Journal = {SIGSAM Bulletin}, + Keywords = {DOI 10.1145/1089302.1089303 ISSN 0163-5824}, + Month = {August 1}, + Number = {3}, + Pages = {3-6}, + Title = {On the Parallel Risch Algorithm (III): Use of Tangents}, + Volume = {16}, + Year = {1982}} + +@misc{Dav79, + Author = {James H. Davenport}, + Date-Added = {2012-03-06 13:57:23 -0500}, + Date-Modified = {2012-03-06 13:58:17 -0500}, + Howpublished = {VM/370 SPAD.SCRIPTS}, + Month = {August 24}, + Title = {SPAD.SCRIPT}, + Year = {1979}} + +@periodical{Daly12, + Author = {Timothy Daly}, + Date-Added = {2012-03-06 13:55:56 -0500}, + Date-Modified = {2012-03-06 13:57:07 -0500}, + Journal = {Notices of the American Mathematical Society}, + Title = {Publishing Computational Mathematics}, + Volume = {\verb|www.ams.org/notices/201202/rtx120200320p.pdf|}, + Year = {Feb 2012}} + +@book{Daly05, + Address = {860 Aviation Parkway, Suite 300, Morrisville, NC 27560}, + Author = {Timothy Daly}, + Date-Added = {2012-03-06 13:53:26 -0500}, + Date-Modified = {2012-03-06 13:55:50 -0500}, + Edition = {\verb|www.lulu.com/content/190827|}, + Keywords = {ISBN 141166597X 287pages}, + Publisher = {Lulu, Inc}, + Title = {Axiom Volume 1: Tutorial}, + Year = {1995}} + +@url{Daly09, + Author = {Timothy Daly}, + Date-Added = {2012-03-06 13:52:37 -0500}, + Date-Modified = {2012-03-06 13:53:13 -0500}, + Title = {The Axiom Literate Documentation}, + Urldate = {\verb|axiom-developer.org/axiom-website/documentation.html|}} + +@url{Daly03, + Author = {Timothy Daly}, + Date-Added = {2012-03-06 13:51:51 -0500}, + Date-Modified = {2012-03-06 13:52:31 -0500}, + Title = {The Axiom Website}, + Urldate = {\verb|axiom-developer.org|}} + +@misc{Daly88, + Author = {Timothy Daly}, + Date-Added = {2012-03-06 13:50:54 -0500}, + Date-Modified = {2012-03-06 13:51:43 -0500}, + Howpublished = {Axiom course slide deck}, + Month = {January}, + Title = {Axiom in an Educational Setting}, + Year = {1988}} + +@inproceedings{Dal92, + Address = {New York, NY 10036 USA}, + Author = {Stephane Dalmas}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-06 13:48:53 -0500}, + Date-Modified = {2012-03-07 03:39:12 -0500}, + Editor = {Paul S. Wang}, + Keywords = {ISBN 0-89791-489-9 LCCN QA76.95.I59 1992}, + Organization = {Association for Computing Machinery}, + Pages = {369-375}, + Publisher = {ACM Press}, + Title = {A polymorphic functional language applied to symbolic computation}, + Year = {1992}} + +@inproceedings{Gil92, + Address = {New York, NY 10036 USA}, + Author = {I. Gil}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-06 13:47:24 -0500}, + Date-Modified = {2012-03-06 13:48:40 -0500}, + Editor = {Paul S. Wang}, + Keywords = {ISBN 0-89791-489-9 LCCN QA76.95.I59 1992}, + Organization = {Association for Computing Machinery}, + Pages = {138-145}, + Publisher = {ACM Press}, + Title = {Computation of the Jordan canonical form of a square matrix (using the Axiom programming language)}, + Year = {1992}} + +@inproceedings{Rio92, + Address = {New York, NY 10036 USA}, + Author = {R. Rioboo}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-06 13:45:06 -0500}, + Date-Modified = {2012-03-06 13:47:01 -0500}, + Editor = {Paul S. Wang}, + Keywords = {ISBN 0-89791-489-9 LCCN QA76.95.I59 1992}, + Organization = {Association for Computing Machinery}, + Pages = {206-215}, + Publisher = {ACM Press}, + Title = {Real algebraic closure of an ordered field, implementation in Axiom}, + Year = {1992}} + +@proceedings{Wang92, + Address = {New York, NY 10036 USA}, + Date-Added = {2012-03-06 13:33:50 -0500}, + Date-Modified = {2012-03-06 13:46:50 -0500}, + Editor = {Paul S. Wang}, + Keywords = {ISBN 0-89791-489-9 LCCN QA76.95.I59 1992}, + Organization = {Association for Computing Machinery}, + Publisher = {ACM Press}, + Title = {International Symposium on Symbolic and Algebraic Computation}, + Year = {1992}} + +@url{CHK, + Author = {Hans Cuypers, Maxim Hendriks, Jan Willem Knopper}, + Date-Added = {2012-03-06 13:32:11 -0500}, + Date-Modified = {2012-03-06 13:33:17 -0500}, + Title = {Interactive Geometry inside MathDox}, + Urldate = {\verb|www.win.tue.nl/~hansc/MathDox_and_InterGeo_paper.pdf|}} + +@misc{CCBS, + Author = {Arjeh M. Cohen, Hans Cuypers, Ernesto Reinaldo Barreiro, Hans Sterk}, + Date-Added = {2012-03-06 13:25:27 -0500}, + Date-Modified = {2012-03-06 13:31:58 -0500}, + Howpublished = {Springer 9783540002576-c1.pdf}, + Title = {Interactive Mathematical Documents on the Web}} + +@proceedings{CJ86, + Booktitle = {International Conference on Computers and Mathematics}, + Date-Added = {2012-03-06 13:21:46 -0500}, + Date-Modified = {2012-03-07 03:40:26 -0500}, + Editor = {David Chudnovsky, Richard Jenks}, + Keywords = {ISBN 0-8247-8341-7}, + Month = {July 29 - August 1}, + Publisher = {Marcel Dekker, Inc}, + Title = {Computers in Mathematics}, + Year = {1986}} + +@inproceedings{Chu89, + Author = {D.V. Chudnovsky, G.V. Chudnovsky}, + Booktitle = {Proceedings of the National Academy of Science}, + Date-Added = {2012-03-06 13:19:36 -0500}, + Date-Modified = {2012-03-06 13:21:21 -0500}, + Pages = {8178-8182}, + Title = {The computation of classical constants}, + Volume = {86}, + Year = {1989}} + +@url{CCCS, + Author = {Olga Capriotti, Arjeh M. Cohen, Hans Cuypers, Hans Sterk}, + Date-Added = {2012-03-06 13:18:20 -0500}, + Date-Modified = {2012-03-06 13:19:24 -0500}, + Title = {OpenMath Technology for Interactive Mathematical Documents}, + Urldate = {\verb|www.win.tue.nl/~hansc/lisbon.pdf|}} + +@url{CC99, + Author = {O. Capriotti, D. Carlisle}, + Date-Added = {2012-03-06 13:17:09 -0500}, + Date-Modified = {2012-03-06 13:18:11 -0500}, + Lastchecked = {1999}, + Title = {OpenMath and MathML: Semantic Mark Up for Mathematics}, + Urldate = {\verb|www.acm.org/crossroads/xrds6-2/openmath.html|}} + +@url{CCR, + Author = {Olga Caprotti, Arjeh M. Cohen, Manfred Riem}, + Date-Added = {2012-03-06 13:14:04 -0500}, + Date-Modified = {2012-03-06 13:15:30 -0500}, + Title = {Java Phrasebooks for Computer Algebra and Automated Deduction}, + Urldate = {\verb|www.sigsam.org/bulletin/articles/132/paper8.pdf|}} + +@techreport{CCM92, + Address = {Le Chesnay, France}, + Author = {Paul Camion, Bernard Courteau, Andre Montpetit}, + Date-Added = {2012-03-06 13:10:44 -0500}, + Date-Modified = {2012-03-06 13:13:23 -0500}, + Institution = {Institut National de Recherche en Informatique et en Automatique}, + Keywords = {English: A combinatorial problem in Haming Graphs and its solution in Scratchpad}, + Month = {January}, + Title = {Un probl{\'e}me combinatoire dans les graphs de Haming et sa solution en Scratchpad}, + Year = {1992}} + +@proceedings{Cal94, + Address = {Karlsruhe, Germany}, + Date-Added = {2012-03-06 13:08:24 -0500}, + Date-Modified = {2012-03-06 13:10:17 -0500}, + Editor = {J. Calmet}, + Organization = {Universit{\"a}t Karlsruhe}, + Publisher = {Universit{\"a}t Karlsruhe}, + Title = {Rhine Workshop on Computer Algebra}, + Year = {1994}} + +@inproceedings{KKM87, + Address = {Berlin, Germany}, + Author = {K. Kusche, B. Kutzler, H. Mayr}, + Booktitle = {European Conference on Computer Algebra}, + Date-Added = {2012-03-06 13:06:00 -0500}, + Date-Modified = {2012-03-06 13:07:42 -0500}, + Editor = {James H. Davenport}, + Keywords = {ISBN 3-540-51517-8 LCCN QA155.7.E4E86 1987}, + Organization = {Springer-Verlag}, + Pages = {246-257}, + Publisher = {Springer-Verlag}, + Title = {Implementation of a geometry theorem proving package in SCRATCHPAD II}, + Year = {1987}} + +@inproceedings{BW87, + Address = {Berlin, Germany}, + Author = {William H. Burge, Stephen M. Watt}, + Booktitle = {European Conference on Computer Algebra}, + Date-Added = {2012-03-06 13:03:23 -0500}, + Date-Modified = {2012-03-06 13:05:45 -0500}, + Editor = {James H. Davenport}, + Keywords = {ISBN 3-540-51517-8 LCCN QA155.7.E4E86 1987}, + Organization = {Springer-Verlag}, + Pages = {138-148}, + Publisher = {Springer-Verlag}, + Title = {Infinite structures in Scratchpad II}, + Year = {1897}} + +@proceedings{Dav87, + Address = {Berlin, Germany}, + Date-Added = {2012-03-06 12:56:43 -0500}, + Date-Modified = {2012-03-06 13:07:24 -0500}, + Editor = {James H. Davenport}, + Keywords = {ISBN 3-540-51517-8 LCCN QA155.7.E4E86 1987}, + Organization = {Springer-Verlag}, + Publisher = {Springer-Verlag}, + Title = {European Conference on Computer Algebra}, + Year = {1987}} + +@techreport{BW87, + Address = {P.O. Box 218, Yorktown Heights, NY 10598}, + Author = {William H. Burge and Stephen M. Watt}, + Date-Added = {2012-03-06 12:54:14 -0500}, + Date-Modified = {2012-03-06 12:56:26 -0500}, + Institution = {IBM Thomas J. Watson Research Center}, + Number = {57573}, + Title = {Infinte structures in SCRATCHPAD II}, + Type = {Research Report RC 12794}, + Year = {1987}} + +@article{Buh05, + Author = {Soren L. Buhl}, + Date-Added = {2012-03-06 12:52:38 -0500}, + Date-Modified = {2012-03-06 12:54:05 -0500}, + Journal = {\verb|www.math.auc.dk/~slb/kurser/software/RCompAlg.pdf|}, + Title = {Some Reflections on Integrating a Computer Algebra System in R}, + Year = {2005}} + +@periodical{BT94, + Author = {R. Brown, A. Tonks}, + Date-Added = {2012-03-06 12:50:43 -0500}, + Date-Modified = {2012-03-06 12:52:32 -0500}, + Journal = {Journal of Symbolic Computation}, + Keywords = {ISSN 0747-7171}, + Pages = {159-179}, + Title = {Calculations with simplicial and cubical groups}, + Volume = {17(2)}, + Year = {Feb 1994}} + +@article{Bor00, + Author = {Jonathan Borwein}, + Date-Added = {2012-03-06 12:47:54 -0500}, + Date-Modified = {2012-03-06 12:50:36 -0500}, + Journal = {Springer-Verlag}, + Keywords = {ISBN 3-540-42450-4}, + Pages = {58}, + Title = {Multimedia tools for communicating mathematics}, + Year = {2000}} + +@article{BS94, + Author = {T. Beneke, W. Schwippert}, + Date-Added = {2012-03-06 12:45:51 -0500}, + Date-Modified = {2012-03-06 12:47:47 -0500}, + Journal = {Electronik}, + Keywords = {ISSN 0013-5658}, + Month = {July}, + Number = {15}, + Pages = {107-110}, + Title = {Double-track into the future: MathCAS will gain new users with Standard and Plus versions}, + Volume = {43}, + Year = {1994}} + +@article{Bru09, + Author = {J. C. Brunelli}, + Date-Added = {2012-03-06 12:41:03 -0500}, + Date-Modified = {2012-03-06 12:43:25 -0500}, + Journal = {\verb|arxiv.org/PS_cache/nlin/pdf/0408/0408058v1.pdf|}, + Title = {Streams and Lazy Evaluation Applied to Integrable Models}, + Year = {1998}} + +@periodical{hitz04, + Author = {Markus A. Hitz}, + Date-Added = {2012-03-06 11:31:34 -0500}, + Date-Modified = {2012-03-06 11:33:55 -0500}, + Journal = {ISSAC 2004}, + Keywords = {\verb|www.sigsam.org/issac/2004/poster-abstracts/abstract13.pdf|}, + Title = {Aspect-Oriented Programming in the Design of Computer Algebra Libraries}, + Year = {2004}} + +@periodical{Daly02b, + Author = {Timothy Daly}, + Date-Added = {2012-03-06 11:27:56 -0500}, + Date-Modified = {2012-03-06 11:29:06 -0500}, + Journal = {SIGSAM Bulletin}, + Keywords = {\verb|www.sigsam.org/cca/issues/issue139.html|}, + Pages = {28}, + Title = {Axiom as Open Source}, + Volume = {36(1) Issue 139}, + Year = {March 2002}} + +@periodical{Daly02a, + Author = {Timothy Daly}, + Date-Added = {2012-03-06 11:26:35 -0500}, + Date-Modified = {2012-03-06 11:29:08 -0500}, + Journal = {SIGSAM Bulletin}, + Keywords = {\verb|www.sigsam.org/cca/issues/issue139.html|}, + Pages = {24}, + Title = {Open Source Workshop}, + Volume = {36(1) Issue 139}, + Year = {March 2002}} + +@periodical{Bau04, + Author = {Gilbert Baumslag}, + Date-Added = {2012-03-06 11:21:42 -0500}, + Date-Modified = {2012-03-06 11:24:33 -0500}, + Howpublished = {\verb|www.sigsam.org/cca/issues/issue150.html|}, + Journal = {SIGSAM Bulletin}, + Keywords = {CCNY conference, Chair: Tim Daly}, + Pages = {134}, + Title = {Axiom Conference}, + Volume = {30(4) Issue 150}, + Year = {2004}} + +@misc{Vol07, + Author = {Emil Volcheck}, + Date-Added = {2012-03-06 11:15:10 -0500}, + Date-Modified = {2012-03-06 11:20:32 -0500}, + Howpublished = {\verb|www.sigsam.org/reports/officers/AGM/2007/Past_Chair_Report_2007.pdf|}, + Month = {August}, + Title = {Chair's Report 2006-2007}, + Year = {2007}} + +@misc{acm12, + Date-Added = {2012-03-06 11:09:42 -0500}, + Date-Modified = {2012-03-06 11:10:35 -0500}, + Howpublished = {\verb|www.sigsam.org/software/index.phtml|}, + Title = {Computer Algebra Software}, + Year = {2012}} + +@misc{jor03, + Author = {Joris van der Hoeven}, + Date-Added = {2012-03-06 10:59:48 -0500}, + Date-Modified = {2012-03-06 11:08:37 -0500}, + Howpublished = {\verb|www.sigsam.org/issac/2003/Software/Hoeven.pdf|}, + Title = {GNU TeXmacs}, + Year = {2003}} + +@proceedings{issac07, + Address = {New York, NY 10036 USA}, + Date-Added = {2012-03-06 10:52:52 -0500}, + Date-Modified = {2012-03-06 10:53:57 -0500}, + Keywords = {ISBN 978-1-59593-743-8 DOI 10.1145/1277548.1277595}, + Organization = {Association for Computing Machinery}, + Publisher = {ACM Press}, + Title = {International Symposium on Symbolic and Algebraic Computation}, + Year = {2007}} + +@inproceedings{SRJ07, + Author = {Jacob Smith, Gabriel Dos Reis, Jaakko Jarvi}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-06 10:47:59 -0500}, + Date-Modified = {2012-03-06 10:54:03 -0500}, + Keywords = {ISBN 978-1-59593-743-8 DOI 10.1145/1277548.1277595}, + Organization = {Association for Computing Machinery}, + Pages = {347-354}, + Publisher = {ACM Press}, + Title = {Algorithmic differentiation in Axiom}, + Year = {2007}} + +@inproceedings{BS93, + Address = {\verb|www.acm.org/pubs/citations/proceedings/issac/164081/p157-bronstein|}, + Author = {Manuel Bronstein}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-06 10:35:17 -0500}, + Date-Modified = {2012-03-06 10:47:20 -0500}, + Editor = {Manuel Bronstein}, + Keywords = {ISBN 0-89791-604-2 LCCN QA76.95.I95 1993 ACM order number 505930}, + Month = {July 6-8}, + Organization = {Association for Computing Machinery}, + Pages = {157-160}, + Publisher = {ACM Press}, + Title = {Full partial fraction decomposition of rational functions}, + Year = {1993}} + +@proceedings{Bro93, + Address = {New York, NY 10036 USA}, + Date-Added = {2012-03-06 10:33:00 -0500}, + Date-Modified = {2012-03-06 10:35:18 -0500}, + Editor = {Manuel Bronstein}, + Keywords = {ISBN 0-89791-604-2 LCCN QA76.95.I95 1993 ACM order number 505930}, + Month = {July 6-8}, + Organization = {Association for Computing Machinery}, + Publisher = {ACM Press}, + Title = {International Symposium on Symbolic and Algebraic Computation}, + Year = {1993}} + +@inproceedings{DGT91, + Address = {New York, NY 10036 USA}, + Author = {James H. Davenport, P. Gianni, Barry M. Trager}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-06 10:27:52 -0500}, + Date-Modified = {2012-03-06 10:30:40 -0500}, + Editor = {Stephen M. Watt}, + Keywords = {ISBN 0-89791-437-6 LCCN QA76.95.I59 1991 Axiom Technical Report ATR/2 NAG Ltd, Oxford 1992}, + Month = {July 15-17}, + Organization = {Association for Computing Machinery}, + Pages = {32-38}, + Publisher = {ACM Press}, + Title = {Scratchpad's view of algebra II: A categorical view of factorization}, + Year = {1991}} + +@inproceedings{Bur91, + Address = {New York, NY 10036 USA}, + Author = {William H. Burge}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-06 10:25:51 -0500}, + Date-Modified = {2012-03-06 10:27:38 -0500}, + Editor = {Stephen M. Watt}, + Keywords = {ISBN 0-89791-437-6 LCCN QA76.95.I59 1991}, + Month = {July 15-17}, + Organization = {Association for Computing Machinery}, + Pages = {189-190}, + Title = {Scratchpad and the Rogers-Ramanujan identities}, + Year = {1991}} + +@inproceedings{Bro91, + Address = {New York, NY 10036 USA}, + Author = {Manuel Bronstein}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-06 10:23:00 -0500}, + Date-Modified = {2012-03-06 10:25:38 -0500}, + Editor = {Stephen M. Watt}, + Keywords = {ISBN 0-89791-437-6 LCCN QA76.95.I59 1991}, + Month = {July 15-17}, + Organization = {Association for Computing Machinery}, + Pages = {241-246}, + Publisher = {ACM Press}, + Title = {The Risch differential equation on an algebraic curve}, + Year = {1991}} + +@proceedings{Wat91, + Address = {New York, NY 10036 USA}, + Date-Added = {2012-03-06 10:21:13 -0500}, + Date-Modified = {2012-03-06 10:30:56 -0500}, + Editor = {Stephen M. Watt}, + Keywords = {ISBN 0-89791-437-6 LCCN QA76.95.I59 1991}, + Month = {July 15-17}, + Organization = {Association for Computing Machinery}, + Publisher = {ACM Press}, + Title = {International Symposium on Symbolic and Algebraic Computation}, + Year = {1991}} + +@periodical{Bro89, + Author = {Manuel Bronstein}, + Date-Added = {2012-03-06 10:19:02 -0500}, + Date-Modified = {2012-03-06 10:20:41 -0500}, + Journal = {ACM}, + Keywords = {ISBN 0-89791-325-6 LCCN QA76.95.I59 1989}, + Pages = {207-211}, + Title = {Simplification of real elementary functions}, + Year = {1989}} + +@periodical{Bou95, + Author = {J. L. Boulanger}, + Date-Added = {2012-03-06 10:17:25 -0500}, + Date-Modified = {2012-03-06 10:18:55 -0500}, + Journal = {ACM SIGPLAN Notices}, + Keywords = {ISSN 0362-1340}, + Pages = {33-41}, + Title = {Object oriented method for Axiom}, + Volume = {30(2)}, + Year = {Feb 1995}} + +@periodical{Boe89, + Author = {Hans-J. Boehm}, + Date-Added = {2012-03-06 10:13:39 -0500}, + Date-Modified = {2012-03-06 10:16:34 -0500}, + Journal = {ACM SIGPLAN Notices}, + Keywords = {\verb|www.acm.org/pubs/citations/proceedings/pldi/73141/p192-boehm|}, + Pages = {192-206}, + Title = {Type inference in the presence of type abstraction}, + Volume = {24(7)}, + Year = {1989}} + +@inproceedings{BGDW95, + Address = {\verb|www.acm.org/pubs/citations/proceedings/issac/220346/p77-broadbery|}, + Author = {Peter Broadbery, Teresa G{\'o}mez-D{\'i}az, Stephen M. Watt}, + Booktitle = {International Symposium on Symbolic and Algebraic Computation}, + Date-Added = {2012-03-06 10:08:47 -0500}, + Date-Modified = {2012-03-06 10:12:59 -0500}, + Editor = {A. H. M. Levelt}, + Keywords = {ISBN 0-89791-699-9 LCCN QA76.95 I59 1995 ACM Order Number 505950}, + Month = {July 10-12}, + Organization = {Association for Computing Machinery}, + Pages = {77-84}, + Publisher = {ACM Press}, + Title = {On the implementation of dynamic evaluation}, + Year = {1995}} + +@proceedings{Lev95, + Address = {Montreal, Canada}, + Date-Added = {2012-03-06 10:06:22 -0500}, + Date-Modified = {2012-03-06 10:12:41 -0500}, + Editor = {A. H. M. Levelt}, + Keywords = {ISBN 0-89791-699-9 LCCN QA76.95 I59 1995 ACM Order Number 505950}, + Month = {July 10-12}, + Organization = {Association for Computing Machinery}, + Publisher = {ACM Press}, + Title = {International Symposium on Symbolic and Algebraic Computation}, + Year = {1995}} + +@proceedings{BC85v2, + Address = {Berlin, Germany}, + Date-Added = {2012-03-06 10:02:38 -0500}, + Date-Modified = {2012-03-06 10:04:48 -0500}, + Editor = {Bruno Buchberger, Bob F. Caviness}, + Keywords = {ISBN 0-387-15984-3 LLCN QA155.7.E4 E86 1985BC85v2}, + Month = {April 1-3}, + Number = {Vol 2 of 2}, + Organization = {Springer-Verlag}, + Publisher = {Springer-Verlag}, + Title = {European Conference on Computer Algebra}, + Volume = {204}, + Year = {1985}} + +@proceedings{BC85v1, + Address = {Berlin, Germany}, + Date-Added = {2012-03-06 09:59:45 -0500}, + Date-Modified = {2012-03-06 10:04:50 -0500}, + Editor = {Bruno Buchberger, Bob F. Caviness}, + Keywords = {ISBN 0-387-15983-5 LLCN QA155.7.E4 E86 1985BC85v2}, + Month = {April 1-3}, + Number = {Vol 1 of 2}, + Organization = {Springer-Verlag}, + Publisher = {Springer-Verlag}, + Title = {European Conference on Computer Algebra}, + Volume = {204}, + Year = {1985}} + +@proceedings{Ano95, + Date-Added = {2012-03-06 09:57:48 -0500}, + Date-Modified = {2012-03-06 09:59:18 -0500}, + Keywords = {ISSN 0044-2267}, + Number = {75}, + Organization = {GAMM}, + Title = {Zeitschrift f\"ur Angewandte Mathematik und Physik}, + Volume = {2}, + Year = {1995}} + +@proceedings{Ano92, + Date-Added = {2012-03-06 09:55:29 -0500}, + Date-Modified = {2012-03-06 09:57:31 -0500}, + Keywords = {ISSN 0926-5473}, + Organization = {IFIP TC2/WG 2.5 working conference}, + Publisher = {IFIP Transactions}, + Title = {Programming environments for high-level scientific problem solving}, + Year = {1992}} + +@proceedings{Ano91, + Address = {Washington, DC, USA}, + Date-Added = {2012-03-06 09:53:49 -0500}, + Date-Modified = {2012-03-06 09:55:19 -0500}, + Organization = {American Society for Engineering Education}, + Title = {Challenges of a Changing World}, + Volume = {2}, + Year = {1991}} + +@inproceedings{And88, + Address = {Berlin, Germany}, + Author = {George E. Andrews}, + Booktitle = {Trends in Computer Algebra}, + Date-Added = {2012-03-06 09:50:11 -0500}, + Date-Modified = {2012-03-06 09:52:32 -0500}, + Editor = {R. Jan{\ss}en}, + Keywords = {Lecture Notes in Computer Science ISBN 3-540-18928-6 LCCN QA155.7.E4T74 1988}, + Month = {May 19-21}, + Organization = {Springer-Verlag}, + Pages = {158}, + Publisher = {Springer-Verlag}, + Title = {Application of Scratchpad to problems in special functions and combinatorics}, + Volume = {296}, + Year = {1987}} + +@proceedings{Jan88, + Address = {Berlin, Germany}, + Date-Added = {2012-03-06 09:46:59 -0500}, + Date-Modified = {2012-03-06 09:52:34 -0500}, + Editor = {R. Jan{\ss}en}, + Keywords = {Lecture Notes in Computer Science ISBN 3-540-18928-6 LCCN QA155.7.E4T74 1988}, + Month = {May 19-21}, + Organization = {Springer-Verlag}, + Publisher = {Springer-Verlag}, + Title = {Trends in Computer Algebra}, + Volume = {296}, + Year = {1987}} + +@inproceedings{And84, + Address = {Schenectady, NY, USA}, + Author = {George E. Andrews}, + Booktitle = {1984 MACSYMA Users Conference}, + Date-Added = {2012-03-06 09:43:15 -0500}, + Date-Modified = {2012-03-06 09:45:19 -0500}, + Editor = {V. Ellen Golden, M. A. Hussain}, + Month = {July 23-25}, + Organization = {General Electric}, + Pages = {383}, + Publisher = {General Electric}, + Title = {Ramanujan and SCRATCHPAD}, + Year = {1984}} + +@proceedings{GH84, + Address = {Schenectady, NY, USA}, + Date-Added = {2012-03-06 09:40:38 -0500}, + Date-Modified = {2012-03-06 09:42:45 -0500}, + Editor = {V. Ellen Golden, M. A. Hussain}, + Month = {July 23-25}, + Organization = {General Electric}, + Publisher = {General Electric}, + Title = {1984 MACSYMA Users Conference}, + Year = {1984}} + +@book{AL94, + Author = {William W. Adams, Philippe Loustaunau}, + Date-Added = {2012-03-06 09:37:55 -0500}, + Date-Modified = {2012-03-06 09:39:39 -0500}, + Keywords = {ISBN 0-8218-3804-0}, + Publisher = {American Mathematical Society}, + Title = {An Introduction to Gr\"obner Bases}, + Year = {1994}} + +@inproceedings{ACS91, + Address = {Berlin, Germany}, + Author = {D. Augot, P. Charpin, N. Sendrier}, + Booktitle = {International Symposium on Coding Theory and Applications}, + Date-Added = {2012-03-06 09:34:55 -0500}, + Date-Modified = {2012-03-06 09:37:40 -0500}, + Editor = {G. Cohen and P. Charpin}, + Keywords = {ISBN 0-387-54303-1 LCCN QA268.E95 1990}, + Organization = {Springer-Verlag}, + Pages = {65-73}, + Publisher = {Springer-Verlag}, + Title = {The minimum distance of some binary codes via the Newton's identities}, + Year = {1990}} + +@proceedings{CC91, + Address = {Berlin, Germany}, + Date-Added = {2012-03-06 09:31:00 -0500}, + Date-Modified = {2012-03-06 09:34:08 -0500}, + Editor = {G. Cohen and P. Charpin}, + Keywords = {ISBN 0-387-54303-1 LCCN QA268.E95 1990}, + Organization = {Springer-Verlag}, + Publisher = {Springer-Verlag}, + Title = {International Symposium on Coding Theory and Applications}, + Year = {1990}} + +@proceedings{ACM94, + Address = {New York, NY 10036 USA}, + Date-Added = {2012-03-06 09:27:55 -0500}, + Date-Modified = {2012-03-08 12:19:20 -0500}, + Keywords = {ISBN 0-89791-638-7 LCCN QA76.95.I59 1994}, + Organization = {Association for Computing Machinery}, + Publisher = {ACM Press}, + Title = {International Symposium on Symbolic and Algebraic Computation}, + Year = {1994}} + +@proceedings{ACM89, + Address = {New York, NY 10036 USA}, + Date-Added = {2012-03-06 09:19:13 -0500}, + Date-Modified = {2012-03-06 09:34:27 -0500}, + Editor = {ACM}, + Keywords = {ISBN 0-89791-325-6 LCCN QA76.95.I59 1989}, + Organization = {Association for Computing Machinery}, + Publisher = {ACM Press}, + Title = {International Symposium on Symbolic and Algebraic Computation}, + Year = {1989}} diff --git a/books/bookvolbib.pamphlet b/books/bookvolbib.pamphlet index 930ac58..1716f2f 100644 --- a/books/bookvolbib.pamphlet +++ b/books/bookvolbib.pamphlet @@ -1207,6 +1207,15 @@ Baker, Martin ``3D World Simulation'' Laurent Bertrand. Computing a hyperelliptic integral using arithmetic in the jacobian of the curve. {\sl Applicable Algebra in Engineering, Communication and Computing}, 6:275-298, 1995 +\bibitem[BBM02a]{BBM02a} +K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 +Performance, SIAM Journal of Matrix Analysis, volume 23, pages +929--947, 2002. +\bibitem[BBM02b]{BBM02b} +K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +Algorithm Part II: Aggressive Early Deflation, SIAM Journal +of Matrix Analysis, volume 23, pages 948--973, 2002. \bibitem[Bro88]{Bro88} Bronstein, Manual ``The Transcendental Risch Differential Equation'' J. Symbolic Computation (1990) 9, pp49-60 Feb 1988 @@ -1250,6 +1259,10 @@ University, Aston Triangle, Birmingham B4 7 ET, U. K. \bibitem[Flo63]{Flo63} Floyd, R. W.``Semantic Analysis and Operator Precedence'' JACM 10, 3, 316-333 (1963) +\bibitem[GM74]{GM74} +Gentleman W. M. and Marovich S. B. (1974) More on algorithms +that reveal properties of floating point arithmetic units. +Comms. of the ACM, 17, 276-277. \bibitem[Ga95]{Ga95} Garcia, A. and Stichtenoth, H. ``A tower of Artin-Schreier extensions of function fields attaining the @@ -1280,6 +1293,10 @@ rationelles. {\sl Nouvelles Annales de Math\'{e}matiques} Higham, Nicholas J. ``Accuracy and stability of numerical algorithms'' SIAM Philadelphia, PA ISBN 0-89871-521-0 (2002) +\bibitem[Hig88]{Hig88} +N.J. Higham, "FORTRAN codes for estimating the one-norm of a +real or complex matrix, with applications to condition estimation", ACM +Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. \bibitem[HI96]{HI96} Huang, M.D. and Ierardi, D. ``Efficient algorithms for Riemann-Roch problem and for addition in the @@ -1349,6 +1366,9 @@ Academic Press (1969) Mathematics in Science and Engineering Volume 53-I \bibitem[Luk269]{Luk269} Luke, Yudell L. ``The Special Functions and their Approximations'' Volume II Academic Press (1969) Mathematics in Science and Engineering Volume 53-II +\bibitem[Mal72]{Mal72} +Malcolm M. A. (1972) Algorithms to reveal properties of +floating-point arithmetic. Comms. of the ACM, 15, 949-951. \bibitem[Mar07]{Mar07} Marshak, U. ``HT-AJAX - AJAX framework for Hunchentoot'' \verb|common-lisp.net/project/ht-ajax/ht-ajax.html| @@ -1397,6 +1417,10 @@ Cambridge University Press (1995) ISBN 0-521-43108-5 \bibitem[Pu09]{Pu09} Puffinware LLC ``Singular Value Decomposition (SVD) Tutorial'' \verb|www.puffinwarellc.com/p3a.htm| +\bibitem[QG06}{QG06} +Gregorio Quintana-Orti and Robert van de Geijn, "Improving the +performance of reduction to Hessenberg form," ACM Transactions on +Mathematical Software, 32(2):180-194, June 2006. \bibitem[Ra03]{Ra03} Ramsey, Norman ``Noweb -- A Simple, Extensible Tool for Literate Programming'' \verb|www.eecs.harvard.edu/~nr/noweb| diff --git a/changelog b/changelog index 55bebdf..3768e51 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,10 @@ +20120422 tpd src/axiom-website/patches.html 20120422.01.tpd.patch +20120422 tpd books/bookvolbib.bib add LAPACK bibtex reference +20120422 tpd books/bookvol10.5 add LAPACK reference code +20120422 tpd books/bookvolbib add paper references +20120422 tpd books/bookvol5 add LAPACK contributors +20120422 tpd books/bookvol10.4 add LAPACK contributors +20120422 tpd readme add LAPACK contributors 20120420 tpd src/axiom-website/patches.html 20120420.01.tpd.patch 20120420 tpd src/input/Makefile add cohen.input 20120420 tpd src/input/cohen.input Joel Cohen algebra example diff --git a/readme b/readme index bc91375..6e1defc 100644 --- a/readme +++ b/readme @@ -196,45 +196,49 @@ at the axiom command prompt will prettyprint the list. "Gilbert Baumslag Michael Becker Nelson H. F. Beebe" "Jay Belanger David Bindel Fred Blair" "Vladimir Bondarenko Mark Botch Alexandre Bouyer" -"Peter A. Broadbery Martin Brock Manuel Bronstein" -"Stephen Buchwald Florian Bundschuh Luanne Burns" -"William Burge" +"Karen Braman Peter A. Broadbery Martin Brock" +"Manuel Bronstein Stephen Buchwald Florian Bundschuh" +"Luanne Burns William Burge Ralph Byers" "Quentin Carpent Robert Caviness Bruce Char" -"Ondrej Certik Cheekai Chin David V. Chudnovsky" -"Gregory V. Chudnovsky Mark Clements James Cloos" -"Josh Cohen Christophe Conil Don Coppersmith" -"George Corliss Robert Corless Gary Cornell" -"Meino Cramer Claire Di Crescenzo David Cyganski" +"Ondrej Certik Tzu-Yi Chen Cheekai Chin" +"David V. Chudnovsky Gregory V. Chudnovsky Mark Clements" +"James Cloos Josh Cohen Christophe Conil" +"Don Coppersmith George Corliss Robert Corless" +"Gary Cornell Meino Cramer Claire Di Crescenzo" +"Jeremy Du Croz David Cyganski" "Nathaniel Daly Timothy Daly Sr. Timothy Daly Jr." -"James H. Davenport Didier Deshommes Michael Dewar" +"James H. Davenport David Day James Demmel" +"Didier Deshommes Michael Dewar Jack Dongarra" "Jean Della Dora Gabriel Dos Reis Claire DiCrescendo" -"Sam Dooley Lionel Ducos Lee Duhem" -"Martin Dunstan Brian Dupee Dominique Duval" +"Sam Dooley Lionel Ducos Iain Duff" +"Lee Duhem Martin Dunstan Brian Dupee" +"Dominique Duval" "Robert Edwards Heow Eide-Goodman Lars Erickson" "Richard Fateman Bertfried Fauser Stuart Feldman" "John Fletcher Brian Ford Albrecht Fortenbacher" "George Frances Constantine Frangos Timothy Freeman" "Korrinn Fu" -"Marc Gaetano Rudiger Gebauer Kathy Gerber" -"Patricia Gianni Samantha Goldrich Holger Gollan" -"Teresa Gomez-Diaz Laureano Gonzalez-Vega Stephen Gortler" -"Johannes Grabmeier Matt Grayson Klaus Ebbe Grue" -"James Griesmer Vladimir Grinberg Oswald Gschnitzer" -"Jocelyn Guidry" +"Marc Gaetano Rudiger Gebauer Van de Geijn" +"Kathy Gerber Patricia Gianni Samantha Goldrich" +"Holger Gollan Teresa Gomez-Diaz Laureano Gonzalez-Vega" +"Stephen Gortler Johannes Grabmeier Matt Grayson" +"Klaus Ebbe Grue James Griesmer Vladimir Grinberg" +"Oswald Gschnitzer Ming Gu Jocelyn Guidry" "Gaetan Hache Steve Hague Satoshi Hamaguchi" -"Mike Hansen Richard Harke Bill Hart" -"Vilya Harvey Martin Hassner Arthur S. Hathaway" -"Dan Hatton Waldek Hebisch Karl Hegbloom" -"Ralf Hemmecke Henderson Antoine Hersen" -"Roger House Gernot Hueber" +"Sven Hammarling Mike Hansen Richard Hanson" +"Richard Harke Bill Hart Vilya Harvey" +"Martin Hassner Arthur S. Hathaway Dan Hatton" +"Waldek Hebisch Karl Hegbloom Ralf Hemmecke" +"Henderson Antoine Hersen Roger House" +"Gernot Hueber" "Pietro Iglio" "Alejandro Jakubi Richard Jenks" -"Kai Kaminski Grant Keady Wilfrid Kendall" -"Tony Kennedy Ted Kosan Paul Kosinski" -"Klaus Kusche Bernhard Kutzler" +"William Kahan Kai Kaminski Grant Keady" +"Wilfrid Kendall Tony Kennedy Ted Kosan" +"Paul Kosinski Klaus Kusche Bernhard Kutzler" "Tim Lahey Larry Lambe Kaj Laurson" "George L. Legendre Franz Lehner Frederic Lehobey" -"Michel Levaud Howard Levy Liu Xiaojun" +"Michel Levaud Howard Levy Ren-Cang Li" "Rudiger Loos Michael Lucks Richard Luczak" "Camm Maguire Francois Maltey Alasdair McAndrew" "Bob McElrath Michael McGettrick Ian Meikle" @@ -250,18 +254,19 @@ at the axiom command prompt will prettyprint the list. "Julian A. Padget Bill Page David Parnas" "Susan Pelzel Michel Petitot Didier Pinchon" "Ayal Pinkus Jose Alfredo Portes" -"Claude Quitte" +"Gregorio Quintana-Orti Claude Quitte" "Arthur C. Ralfs Norman Ramsey Anatoly Raportirenko" "Albert D. Rich Michael Richardson Guilherme Reis" -"Renaud Rioboo Jean Rivlin Nicolas Robidoux" -"Simon Robinson Raymond Rogers Michael Rothstein" -"Martin Rubey" +"Huan Ren Renaud Rioboo Jean Rivlin" +"Nicolas Robidoux Simon Robinson Raymond Rogers" +"Michael Rothstein Martin Rubey" "Philip Santas Alfred Scheerhorn William Schelter" "Gerhard Schneider Martin Schoenert Marshall Schor" "Frithjof Schulze Fritz Schwarz Steven Segletes" -"Nick Simicich William Sit Elena Smirnova" -"Jonathan Steinbach Fabio Stumbo Christine Sundaresan" -"Robert Sutor Moss E. Sweedler Eugene Surowitz" +"V. Sima Nick Simicich William Sit" +"Elena Smirnova Jonathan Steinbach Fabio Stumbo" +"Christine Sundaresan Robert Sutor Moss E. Sweedler" +"Eugene Surowitz" "Max Tegmark T. Doug Telford James Thatcher" "Balbir Thomas Mike Thomas Dylan Thurston" "Steve Toleque Barry Trager Themos T. Tsikas" @@ -269,9 +274,11 @@ at the axiom command prompt will prettyprint the list. "Bernhard Wall Stephen Watt Jaap Weel" "Juergen Weiss M. Weller Mark Wegman" "James Wen Thorsten Werther Michael Wester" -"John M. Wiley Berhard Will Clifton J. Williamson" -"Stephen Wilson Shmuel Winograd Robert Wisbauer" -"Sandra Wityak Waldemar Wiwianka Knut Wolf" +"R. Clint Whaley John M. Wiley Berhard Will" +"Clifton J. Williamson Stephen Wilson Shmuel Winograd" +"Robert Wisbauer Sandra Wityak Waldemar Wiwianka" +"Knut Wolf" +"Liu Xiaojun" "Clifford Yapp David Yun" "Vadim Zhytnikov Richard Zippel Evelyn Zoernack" "Bruno Zuercher Dan Zwillinger" diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 2432cc5..4cc46c9 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3884,5 +3884,7 @@ Makefile.pamphlet add <> to all stanzas
src/axiom-website/download.html update download list
20120420.01.tpd.patch src/input/cohen.input Joel Cohen algebra example
+20120422.01.tpd.patch +books/bookvol10.5 add LAPACK reference code