diff --git a/books/bookvol10.5.pamphlet b/books/bookvol10.5.pamphlet new file mode 100644 index 0000000..c3e9aa4 --- /dev/null +++ b/books/bookvol10.5.pamphlet @@ -0,0 +1,61976 @@ +\documentclass[dvipdfm]{book} +\usepackage{hyperref} +\usepackage{amssymb} +\usepackage{axiom} +\usepackage{makeidx} +\makeindex +\usepackage{graphicx} +%% +%% pagehead consolidates standard page indexing +%% +\newcommand{\pagehead}[2]{% e.g. \pagehead{name}{abb} +\section{#1} +\label{#1}% +\label{#2}% +\index{{#1}}% +\index{{#2}}}% +%% +%% pagepic adds an image and an index entry +%% +\newcommand{\pagepic}[3]{% e.g. \pagepic{pathandfile}{abb}{scale} +\includegraphics[scale=#3]{#1}\\% +\index{images!#2}} +%% +%% pageto is a forward link to a referenced page +%% +\newcommand{\pageto}[2]{% e.g. \pageto{abb}{name} +\ \\${\bf\Rightarrow{}}${``#1''} (#2) \ref{#1} on page~\pageref{#1}} +%% +%% pageback is a backward link to a referencing page +%% +\newcommand{\pagefrom}[2]{% e.g. \pagefrom{name}{abb} +\ \\${\bf\Leftarrow{}}${``#1''} (#2) \ref{#1} on page~\pageref{#1}} +%% + +%% cross will put the category and function in the index +%% cross will leave the funcname so it can be put inline. +%% +\newcommand{\cross}[2]{% e.g. \pagefrom{cat}{funcname} +\index{#1!#2}% +\index{#2!#1}% +#2} + +% special meanings for math characters +\providecommand{\N}{\mbox{\bbold N}} +\providecommand{\Natural}{\mbox{\bbold N}} +\providecommand{\Z}{\mbox{\bbold Z}} +\providecommand{\Integer}{\mbox{\bbold Z}} +\providecommand{\Rational}{\mbox{\bbold Q}} +\providecommand{\Q}{\mbox{\bbold Q}} +\providecommand{\Complex}{\mbox{\bbold C}} +\providecommand{\C}{{\mathcal C}} +\providecommand{\Real}{\mbox{\bbold R}} +\providecommand{\F}{{\mathcal F}} +\providecommand{\R}{{\mathcal R}} +\begin{document} +\begin{titlepage} +\center{\includegraphics{ps/axiomfront.ps}} +\vskip 0.1in +\includegraphics{ps/bluebayou.ps}\\ +\vskip 0.1in +{\Huge{The 30 Year Horizon}} +\vskip 0.1in +$$ +\begin{array}{lll} +Manuel\ Bronstein & William\ Burge & Timothy\ Daly \\ +James\ Davenport & Michael\ Dewar & Martin\ Dunstan \\ +Albrecht\ Fortenbacher & Patrizia\ Gianni & Johannes\ Grabmeier \\ +Jocelyn\ Guidry & Richard\ Jenks & Larry\ Lambe \\ +Michael\ Monagan & Scott\ Morrison & William\ Sit \\ +Jonathan\ Steinbach & Robert\ Sutor & Barry\ Trager \\ +Stephen\ Watt & Jim\ Wen & Clifton\ Williamson +\end{array} +$$ +\center{\large{Volume 10: Axiom Algebra: Numerical Routines}} +\end{titlepage} +\pagenumbering{roman} +\begin{verbatim} +Portions Copyright (c) 2005 Timothy Daly + +The Blue Bayou image Copyright (c) 2004 Jocelyn Guidry + +Portions Copyright (c) 2004 Martin Dunstan + +Portions Copyright (c) 1991-2002, +The Numerical ALgorithms Group Ltd. +All rights reserved. + +This book and the Axiom software is licensed as follows: + +Redistribution and use in source and binary forms, with or +without modification, are permitted provided that the following +conditions are +met: + + - Redistributions of source code must retain the above + copyright notice, this list of conditions and the + following disclaimer. + + - Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the + following disclaimer in the documentation and/or other + materials provided with the distribution. + + - Neither the name of The Numerical ALgorithms Group Ltd. + nor the names of its contributors may be used to endorse + or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND +CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. + +\end{verbatim} + +Inclusion of names in the list of credits is based on historical +information and is as accurate as possible. Inclusion of names +does not in any way imply an endorsement but represents historical +influence on Axiom development. +\vfill +\eject +\begin{tabular}{lll} +Cyril Alberga & Roy Adler & Richard Anderson\\ +George Andrews & Henry Baker & Stephen Balzac\\ +Yurij Baransky & David R. Barton & Gerald Baumgartner\\ +Gilbert Baumslag & Fred Blair & Vladimir Bondarenko\\ +Mark Botch & Alexandre Bouyer & Peter A. Broadbery\\ +Martin Brock & Manuel Bronstein & Florian Bundschuh\\ +William Burge & Quentin Carpent & Bob Caviness\\ +Bruce Char & Cheekai Chin & David V. Chudnovsky\\ +Gregory V. Chudnovsky & Josh Cohen & Christophe Conil\\ +Don Coppersmith & George Corliss & Robert Corless\\ +Gary Cornell & Meino Cramer & Claire Di Crescenzo\\ +Timothy Daly Sr. & Timothy Daly Jr. & James H. Davenport\\ +Jean Della Dora & Gabriel Dos Reis & Michael Dewar\\ +Claire DiCrescendo & Sam Dooley & Lionel Ducos\\ +Martin Dunstan & Brian Dupee & Dominique Duval\\ +Robert Edwards & Heow Eide-Goodman & Lars Erickson\\ +Richard Fateman & Bertfried Fauser & Stuart Feldman\\ +Brian Ford & Albrecht Fortenbacher & George Frances\\ +Constantine Frangos & Timothy Freeman & Korrinn Fu\\ +Marc Gaetano & Rudiger Gebauer & Kathy Gerber\\ +Patricia Gianni & Holger Gollan & Teresa Gomez-Diaz\\ +Laureano Gonzalez-Vega& Stephen Gortler & Johannes Grabmeier\\ +Matt Grayson & James Griesmer & Vladimir Grinberg\\ +Oswald Gschnitzer & Jocelyn Guidry & Steve Hague\\ +Vilya Harvey & Satoshi Hamaguchi & Martin Hassner\\ +Ralf Hemmecke & Henderson & Antoine Hersen\\ +Pietro Iglio & Richard Jenks & Kai Kaminski\\ +Grant Keady & Tony Kennedy & Paul Kosinski\\ +Klaus Kusche & Bernhard Kutzler & Larry Lambe\\ +Frederic Lehobey & Michel Levaud & Howard Levy\\ +Rudiger Loos & Michael Lucks & Richard Luczak\\ +Camm Maguire & Bob McElrath & Michael McGettrick\\ +Ian Meikle & David Mentre & Victor S. Miller\\ +Gerard Milmeister & Mohammed Mobarak & H. Michael Moeller\\ +Michael Monagan & Marc Moreno-Maza & Scott Morrison\\ +Mark Murray & William Naylor & C. Andrew Neff\\ +John Nelder & Godfrey Nolan & Arthur Norman\\ +Jinzhong Niu & Michael O'Connor & Kostas Oikonomou\\ +Julian A. Padget & Bill Page & Jaap Weel\\ +Susan Pelzel & Michel Petitot & Didier Pinchon\\ +Claude Quitte & Norman Ramsey & Michael Richardson\\ +Renaud Rioboo & Jean Rivlin & Nicolas Robidoux\\ +Simon Robinson & Michael Rothstein & Martin Rubey\\ +Philip Santas & Alfred Scheerhorn & William Schelter\\ +Gerhard Schneider & Martin Schoenert & Marshall Schor\\ +Fritz Schwarz & Nick Simicich & William Sit\\ +Elena Smirnova & Jonathan Steinbach & Christine Sundaresan\\ +Robert Sutor & Moss E. Sweedler & Eugene Surowitz\\ +James Thatcher & Baldir Thomas & Mike Thomas\\ +Dylan Thurston & Barry Trager & Themos T. Tsikas\\ +Gregory Vanuxem & Bernhard Wall & Stephen Watt\\ +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\\ +Clifford Yapp & David Yun & Richard Zippel\\ +Evelyn Zoernack & Bruno Zuercher & Dan Zwillinger +\end{tabular} +\eject +\tableofcontents +\vfill +\eject +\setlength{\parindent}{0em} +\setlength{\parskip}{1ex} +{\Large{\bf New Foreword}} +\vskip .25in + +On October 1, 2001 Axiom was withdrawn from the market and ended +life as a commercial product. +On September 3, 2002 Axiom was released under the Modified BSD +license, including this document. +On August 27, 2003 Axiom was released as free and open source +software available for download from the Free Software Foundation's +website, Savannah. + +Work on Axiom has had the generous support of the Center for +Algorithms and Interactive Scientific Computation (CAISS) at +City College of New York. Special thanks go to Dr. Gilbert +Baumslag for his support of the long term goal. + +The online version of this documentation is roughly 1000 pages. +In order to make printed versions we've broken it up into three +volumes. The first volume is tutorial in nature. The second volume +is for programmers. The third volume is reference material. We've +also added a fourth volume for developers. All of these changes +represent an experiment in print-on-demand delivery of documentation. +Time will tell whether the experiment succeeded. + +Axiom has been in existence for over thirty years. It is estimated to +contain about three hundred man-years of research and has, as of +September 3, 2003, 143 people listed in the credits. All of these +people have contributed directly or indirectly to making Axiom +available. Axiom is being passed to the next generation. I'm looking +forward to future milestones. + +With that in mind I've introduced the theme of the ``30 year horizon''. +We must invent the tools that support the Computational Mathematician +working 30 years from now. How will research be done when every bit of +mathematical knowledge is online and instantly available? What happens +when we scale Axiom by a factor of 100, giving us 1.1 million domains? +How can we integrate theory with code? How will we integrate theorems +and proofs of the mathematics with space-time complexity proofs and +running code? What visualization tools are needed? How do we support +the conceptual structures and semantics of mathematics in effective +ways? How do we support results from the sciences? How do we teach +the next generation to be effective Computational Mathematicians? + +The ``30 year horizon'' is much nearer than it appears. + +\vskip .25in +%\noindent +Tim Daly\\ +CAISS, City College of New York\\ +November 10, 2003 ((iHy)) +\vfill +\eject +\pagenumbering{arabic} +\chapter{Chapter Overview} +Each routine in the Basic Linear Algebra Subroutine set (BLAS) has +a prefix where: +\begin{itemize} +\item C - Complex +\item D - Double Precision +\item S - Real +\item Z - Complex*16 +\end{itemize} +Routines in level 2 and level 3 of BLAS use the prefix for type: +\begin{itemize} +\item GE - general +\item GB - general band +\item SY - symmetric +\item HE - hermitian +\item TR - triangular +\item SB - symmetric band +\item HB - hermetian band +\item TB - triangular band +\item SP - Sum packed +\item HP - hermitian packed +\item TP - triangular packed +\end{itemize} +For level 2 and level 3 BLAS options the options argument is CHARACTER*1 +and may be passed as character strings. They mean: +\begin{itemize} +\item TRANx +\begin{itemize} +\item {\bf N}o transpose +\item {\bf T}ranspose +\item {\bf C}onjugate transpose ($X$, $X^T$, $X^H$) +\end{itemize} +\item UPLO +\begin{itemize} +\item {\bf U}pper triangular +\item {\bf L}ower triangular +\end{itemize} +\item DIAG +\begin{itemize} +\item {\bf N}on-unit triangular +\item {\bf U}nit triangular +\end{itemize} +\item SIDE +\begin{itemize} +\item {\bf L}eft - A or op(A) on the left +\item {\bf R}ight - A or op(A) on the right +\end{itemize} +\end{itemize} +For real matrices, TRANSx=T and TRANSx=C have the same meaning. +For Hermitian matrices, TRANSx=T is not allowed. +For complex symmetric matrices, TRANSx=H is not allowed. +\chapter{Algebra Cover Code} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{package BLAS1 BlasLevelOne} +\pagehead{BlasLevelOne}{BLAS1} +%\pagepic{ps/v104blaslevelone.ps}{BLAS1}{1.00} + +{\bf Exports:}\\ +\begin{tabular}{lllll} +\cross{AF}{?**?} & +\end{tabular} + +<>= +)abbrev package BLAS1 BlasLevelOne +++ Author: Gregory Vanuxem +++ Date Created: 2006 +++ Date Last Updated: Aug 14, 2006 +++ Basic Operations: +++ Related Domains: Vector +++ Also See: +++ AMS Classifications: +++ Keywords: +++ Examples: +++ References: +++ Description: +++ This package provides an interface to the Blas library (level 1) +-- TODO : dimension of vector and not length +BlasLevelOne(V) : Exports == Implementation where + + SI ==> SingleInteger + R ==> DoubleFloat + V : OneDimensionalArrayAggregate(R) with contiguousStorage + + Exports == with + + dot: (SI,V,SI,V,SI) -> R + ++ dot(n,x,incx,y,incy) computes the dot product of two vectors, x and y. + ++ Parameters: + ++ \begin{items} + ++ \item {n}: order of vectors x and y; + ++ \item {x}: the first vector, \#x must be at least (1+(n-1)*abs(incx)); + ++ \item {incx}: increment for the elements of x; + ++ \item {y}: the second vector, \#y must be at least + ++ (1+(n-1)*abs(incy)); + ++ \item {incy}: increment for the elements of y. + ++ \end{items} + + dot: (V,V) -> R + ++ dot(x,y) computes the dot product of two vectors, x and y. + ++ If x and y are not of the same length, it is assumed that they both + ++ have the same length (the smaller). + + nrm2: (SI,V,SI) -> R + ++ nrm2(n,x,incx) computes the euclidean norm of the vector x. + ++ Parameters: + ++ \begin{items} + ++ \item {n}: order of the vector x; + ++ \item {x}: the vector, \#x must be at least (1+(n-1)*abs(incx)); + ++ \item {incx}: Increment for the elements of x. + ++ \end{items} + + nrm2: (V) -> R + ++ nrm2(x) computes the euclidean norm of the vector x. + + asum: (SI,V,SI) -> R + ++ asum(n,x,incx) computes the sum of the absolute values of the vector + ++ elements of x. Parameters: + ++ \begin{items} + ++ \item {n}: order of the vector x; + ++ \item {x}: the vector, \#x must be at least (1+(n-1)*abs(incx)); + ++ \item {incx}: Increment for the elements of x. + ++ \end{items} + + asum: (V) -> R + ++ asum(x) computes the sum of the absolute values of the vector + ++ elements of x. + + iamax: (SI,V,SI) -> SI + ++ iamax(n,x,incx) finds the index of element of a vector that has + ++ the largest absolute value. Parameters: + ++ \begin{items} + ++ \item {n}: order of the vector x; + ++ \item {x}: the vector, \#x must be at least (1+(n-1)*abs(incx)); + ++ \item {incx}: Increment for the elements of x. + ++ \end{items} + + iamax: (V) -> SI + ++ iamax(x) finds the index of element of a vector that has + ++ the largest absolute value. + + swap: (SI,V,SI,V,SI) -> Void + ++ swap(n,x,incx,y,incy) interchanges two vectors, x and y. + ++ Parameters: + ++ \begin{items} + ++ \item {n}: order of vectors x and y; + ++ \item {x}: the first vector, \#x must be at least (1+(n-1)*abs(incx)); + ++ \item {incx}: increment for the elements of x; + ++ \item {y}: the second vector, \#y must be at least + ++ (1+(n-1)*abs(incy)); + ++ \item {incy}: increment for the elements of y. + ++ \end{items} + + swap: (V,V) -> Void + ++ swap(x,y) interchanges two vectors, x and y. + ++ If x and y are not of the same length, it is assumed that they both + ++ have the same length (the smaller). + + copy: (SI,V,SI,V,SI) -> Void + ++ copy(n,x,incx,y,incy) copies a vector, x, to a vector, y. + ++ Parameters: + ++ \begin{items} + ++ \item {n}: order of vectors x and y; + ++ \item {x}: the first vector, \#x must be at least (1+(n-1)*abs(incx)); + ++ \item {incx}: increment for the elements of x; + ++ \item {y}: the second vector, \#y must be at least + ++ (1+(n-1)*abs(incy)); + ++ \item {incy}: increment for the elements of y. + ++ \end{items} + + copy: (V,V) -> Void + ++ copy(x,y) copies a vector, x, to a vector, y. + ++ If x and y are not of the same length, it is assumed that they both + ++ have the same length (the smaller). + + axpy: (SI,R,V,SI,V,SI) -> Void + ++ axpy(n,alpha,x,incx,y,incy) computes the product of a scalar, alpha, + ++ with a vector, x, plus a vector, y. + ++ Parameters: + ++ \begin{items} + ++ \item {n}: order of vectors x and y; + ++ \item {alpha}: a scalar; + ++ \item {x}: the first vector, \#x must be at least (1+(n-1)*abs(incx)); + ++ \item {incx}: increment for the elements of x; + ++ \item {y}: the second vector, \#y must be at least + ++ (1+(n-1)*abs(incy)); + ++ \item {incy}: increment for the elements of y. + ++ \end{items} + + axpy: (R,V,V) -> Void + ++ axpy(alpha,x,y) computes the product of a scalar, alpha, + ++ with a vector, x, plus a vector, y. + ++ If x and y are not of the same length, it is assumed that they both + ++ have the same length (the smaller). + + rot: (SI,V,SI,V,SI,R,R) -> Void + ++ rot(n,x,incx,y,incy,c,s) applies a plane rotation: + ++ x(i) = c*x(i) + s*y(i) + ++ y(i) = c*y(i) - s*x(i) + ++ Parameters: + ++ \begin{items} + ++ \item {n}: order of vectors x and y; + ++ \item {x}: the first vector, \#x must be at least (1+(n-1)*abs(incx)); + ++ \item {incx}: increment for the elements of x; + ++ \item {y}: the second vector, \#y must be at least + ++ (1+(n-1)*abs(incy)); + ++ \item {incy}: increment for the elements of y; + ++ \item {c}: a scalar; + ++ \item {s}: a scalar. + ++ \end{items} + + rot: (V,V,R,R) -> Void + ++ rot(x,y,c,s) applies a plane rotation: + ++ x(i) = c*x(i) + s*y(i) + ++ y(i) = c*y(i) - s*x(i) + ++ If x and y are not of the same length, it is assumed that they both + ++ have the same length (the smaller). + + scal: (SI,R,V,SI) -> Void + ++ scal(n,alpha,x,incx) scales a vector, x, by a scalar, alpha. + ++ Parameters: + ++ \begin{items} + ++ \item {n}: order of the vector x; + ++ \item {alpha}: a scalar; + ++ \item {x}: the vector, \#x must be at least (1+(n-1)*abs(incx)); + ++ \item {incx}: Increment for the elements of x. + ++ \end{items} + + scal: (R,V) -> Void + ++ scal(alpha,x) scales a vector, x, by a scalar, alpha. + + Implementation == add + + dot(n:SI,x:V,incx:SI,y:V,incy:SI): R == + DDOT(n,x,incx,y,incy)$Lisp + + dot(x:V,y:V): R == + n := min(#x,#y)::SI + DDOT(n,x,1$SI,y,1$SI)$Lisp + + nrm2(n:SI,x:V,incx:SI): R == + DNRM2(n,x,incx)$Lisp + + nrm2(x:V): R == + DNRM2(#x::SI,x,1$SI)$Lisp + + asum(n:SI,x:V,incx:SI): R == + DASUM(n,x,incx)$Lisp + + asum(x:V): R == + DASUM(#x::SI,x,1$SI)$Lisp + + iamax(n:SI,x:V,incx:SI): SI == + IDAMAX(n,x,incx)$Lisp + + iamax(x:V): SI == + IDAMAX(#x::SI,x,1$SI)$Lisp + + swap(n:SI,x:V,incx:SI,y:V,incy:SI): Void == + DSWAP(n,x,incx,y,incy)$Lisp + + swap(x:V,y:V): Void == + n := min(#x,#y)::SI + DSWAP(n,x,1$SI,y,1$SI)$Lisp + + copy(n:SI,x:V,incx:SI,y:V,incy:SI): Void == + DCOPY(n,x,incx,y,incy)$Lisp + + copy(x:V,y:V): Void == + n := min(#x,#y)::SI + DCOPY(n,x,1$SI,y,1$SI)$Lisp + + axpy(n:SI,alpha:R,x:V,incx:SI,y:V,incy:SI): Void == + DAXPY(n,alpha,x,incx,y,incy)$Lisp + + axpy(alpha:R,x:V,y:V): Void == + n := min(#x,#y)::SI + DAXPY(n,alpha,x,1$SI,y,1$SI)$Lisp + + rot(n:SI,x:V,incx:SI,y:V,incy:SI,c:R,s:R): Void == + DROT(n,x,incx,y,incy,c,s)$Lisp + + rot(x:V,y:V,c:R,s:R): Void == + n := min(#x,#y)::SI + DROT(n,x,1$SI,y,1$SI,c,s)$Lisp + + scal(n:SI,alpha:R,x:V,incx:SI): Void == + DSCAL(n,alpha,x,incx)$Lisp + + scal(alpha:R,x:V): Void == + DSCAL(#x::SI,alpha,x,1$SI)$Lisp + +@ +<>= +"BLAS1" [color="#FF4488",href="bookvol10.4.pdf#nameddest=BLAS1"] +"FS" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FS"] +"ACF" [color="#4488FF",href="bookvol10.2.pdf#nameddest=ACF"] +"BLAS1" -> "FS" +"BLAS1" -> "ACF" + +@ + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{package BLAS2 BlasLevelTwo} +\pagehead{BlasLevelTwo}{BLAS2} +%\pagepic{ps/v104blasleveltwo.ps}{BLAS2}{1.00} + +{\bf Exports:}\\ +\begin{tabular}{lllll} +\cross{BLAS2}{?**?} & +\end{tabular} + +<>= +)abbrev package BLAS2 BlasLevelTwo +++ Author: Gregory Vanuxem +++ Date Created: 2006 +++ Date Last Updated: Aug 29, 2006 +++ Basic Operations: +++ Related Domains: ColumnMajorTwoDimensionnalArray, Vector +++ Also See: +++ AMS Classifications: +++ Keywords: +++ Examples: +++ References: +++ Description: +++ This package provides an interface to the +++ Blas library (level 2) +BlasLevelTwo(Row,Col,M,V) : Exports == Implementation where + + R ==> DoubleFloat + SI ==> SingleInteger + CHAR ==> Character + V : OneDimensionalArrayAggregate(R) with contiguousStorage + Row : OneDimensionalArrayAggregate(R) with contiguousStorage + Col : OneDimensionalArrayAggregate(R) with contiguousStorage + M : ColumnMajorTwoDimensionalArrayCategory(R,Row,Col) + + Exports == with + + gemv: (CHAR,SI,SI,R,M,SI,V,SI,R,V,SI) -> Void + ++ gemv(trans,m,n,alpha,A,lda,x,incx,beta,y,incy) performs one of + ++ the matrix-vector operations + ++ y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, + ++ where alpha and beta are scalars, x and y are vectors and A is an + ++ m by n matrix. + ++ Parameters: + ++ \begin{items} + ++ \item {trans}: on entry, specifies the operation to be performed as + ++ follows: + ++ trans = 'N' or 'n' y := alpha*A*x + beta*y. + ++ trans = 'T' or 't' y := alpha*A'*x + beta*y. + ++ Unchanged on exit. + ++ \item {m}: on entry, specifies the number of rows of the matrix A. + ++ m must be at least zero. Unchanged on exit. + ++ \item {n}: on entry, specifies the number of columns of the matrix A. + ++ n must be at least zero. Unchanged on exit. + ++ \item {alpha}: on entry, specifies the scalar alpha. + ++ Unchanged on exit. + ++ \item {A}: before entry, the leading m by n part of the array A must + ++ contain the matrix of coefficients. Unchanged on exit. + ++ \item {lda}: on entry, specifies the first dimension of A as declared + ++ in the calling (sub) program. lda must be at least max( 1, m ). + ++ Unchanged on exit. + ++ \item {x}: array of dimension at least ( 1 + ( n - 1 )*abs( incx ) ) + ++ when trans = 'N' or 'n' + ++ and at least ( 1 + ( m - 1 )*abs( incx ) ) otherwise. Before entry, + ++ the incremented array x must contain the + ++ vector x. Unchanged on exit. + ++ \item {incx}: increment for the elements of x. + ++ \item {beta}: on entry, beta specifies the scalar beta. When beta is + ++ supplied as zero then y need not be set on input. Unchanged on exit. + ++ \item {y}: array of dimension at least ( 1 + ( m - 1 )*abs( incy ) ) + ++ when trans = 'N' or 'n' + ++ and at least ( 1 + ( n - 1 )*abs( incy ) ) otherwise. + ++ Before entry with beta non-zero, + ++ the incremented array y must contain the vector y. On exit, + ++ y is overwritten by the updated vector y. + ++ \item {incy}: increment for the elements of y. + ++ \end{items} + + gemv: (CHAR,R,M,V,R,V) -> Void + ++ gemv(trans,alpha,A,x,beta,y) performs one of + ++ the matrix-vector operations + ++ y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, + ++ where alpha and beta are scalars, x and y are vectors and A is an + ++ m by n matrix. + ++ Parameters: + ++ \begin{items} + ++ \item {trans}: on entry, specifies the operation to be performed as + ++ follows: + ++ trans = 'N' or 'n' y := alpha*A*x + beta*y. + ++ trans = 'T' or 't' y := alpha*A'*x + beta*y. + ++ Unchanged on exit. + ++ \item {alpha}: on entry, specifies the scalar alpha. + ++ Unchanged on exit. + ++ \item {A}: before entry, the array A must + ++ contain the matrix of coefficients. Unchanged on exit. + ++ \item {x}: array of dimension at least n when trans = 'N' or 'n' + ++ and at least m otherwise. Before entry, the array x must contain the + ++ vector x. Unchanged on exit. + ++ \item {beta}: on entry, beta specifies the scalar beta. When beta is + ++ supplied as zero then y need not be set on input. Unchanged on exit. + ++ \item {y}: array of dimension at least m when trans = 'N' or 'n' + ++ and at least n otherwise. Before entry with beta non-zero, + ++ the array y must contain the vector y. + ++ On exit, y is overwritten by the updated vector y. + ++ \end{items} + + ger: (SI,SI,R,V,SI,V,SI,M,SI) -> Void + ++ ger(m,n,alpha,x,incx,y,incy,A,lda) performs the rank 1 operation + ++ A := alpha*x*y' + A, + ++ where alpha is a scalar, x is an m-element vector, y is an n-element + ++ vector and A is an m by n matrix. + ++ Parameters: + ++ \begin{items} + ++ \item {m}: on entry, specifies the number of rows of the matrix A. + ++ m must be at least zero. Unchanged on exit. + ++ \item {n}: on entry, specifies the number of columns of the matrix A. + ++ n must be at least zero. Unchanged on exit. + ++ \item {alpha}: on entry, specifies the scalar alpha. + ++ Unchanged on exit. + ++ \item {x}: array of dimension at least ( 1 + ( m - 1 )*abs( incx ) ). + ++ Before entry, the incremented array x must contain the + ++ m-element vector x. Unchanged on exit. + ++ \item {incx}: increment for the elements of x. + ++ \item {y}: array of dimension at least ( 1 + ( n - 1 )*abs( incy ) ). + ++ Before entry, the incremented array y must contain the + ++ n-element vector y. + ++ Unchanged on exit. + ++ \item {incy}: increment for the elements of y. + ++ \item {A}: before entry, the leading m by n part of the array A must + ++ contain the matrix of coefficients. On exit, A is overwritten by the + ++ updated matrix. + ++ \item {lda}: on entry, specifies the first dimension of A as declared + ++ in the calling (sub) program. lda must be at least max( 1, m ). + ++ Unchanged on exit. + ++ \end{items} + + ger: (R,V,V,M) -> Void + ++ ger(alpha,x,y,A) performs the rank 1 operation + ++ A := alpha*x*y' + A, + ++ where alpha is a scalar, x is an m-element vector, y is an n-element + ++ vector and A is an m by n matrix. + ++ Parameters: + ++ \begin{items} + ++ \item {alpha}: on entry, specifies the scalar alpha. + ++ Unchanged on exit. + ++ \item {x}: array of dimension at least m. Before entry, + ++ the array x must + ++ contain the m-element vector x. Unchanged on exit. + ++ \item {y}: array of dimension at least n. + ++ Before entry, the array y must + ++ contain the n-element vector y. Unchanged on exit. + ++ \item {A}: before entry, the array A must + ++ contain the matrix of coefficients. On exit, A is overwritten by the + ++ updated matrix. + ++ \end{items} + + symv: (CHAR,SI,R,M,SI,V,SI,R,V,SI) -> Void + ++ symv(uplo,n,alpha,A,lda,x,incx,beta,y,incy) + ++ performs the matrix-vector operation + ++ y := alpha*A*x + beta*y, + ++ where alpha and beta are scalars, x and y are n-element vectors and + ++ A is an n by n symmetric matrix. + ++ Parameters: + ++ \begin{items} + ++ \item {uplo}: on entry, uplo specifies whether the upper or lower + ++ triangular part of the array A is to be referenced as + ++ follows: + ++ uplo = 'U' or 'u' only the upper triangular part of A + ++ is to be referenced. + ++ uplo = 'L' or 'l' only the lower triangular part of A + ++ is to be referenced. + ++ Unchanged on exit. + ++ \item {n}: on entry, specifies the order of the matrix A. + ++ n must be at least zero. Unchanged on exit. + ++ \item {alpha}: on entry, specifies the scalar alpha. + ++ Unchanged on exit. + ++ \item {A}: before entry with uplo = 'U' or 'u', the leading n by n + ++ upper triangular part of the array A must contain the upper + ++ triangular part of the symmetric matrix and the strictly + ++ lower triangular part of A is not referenced. + ++ Before entry with uplo = 'L' or 'l', the leading n by n + ++ lower triangular part of the array A must contain the lower + ++ triangular part of the symmetric matrix and the strictly + ++ upper triangular part of A is not referenced. + ++ Unchanged on exit. + ++ \item {x}: array of dimension at least ( 1 + ( n - 1 )*abs( incx ) ) + ++ Before entry, the incremented array x must contain the + ++ n-element vector x. Unchanged on exit. + ++ \item {incx}: increment for the elements of x. + ++ \item {beta}: on entry, beta specifies the scalar beta. When beta is + ++ supplied as zero then y need not be set on input. Unchanged on exit. + ++ \item {y}: array of dimension at least ( 1 + ( n - 1 )*abs( incy ) ). + ++ Before entry with beta non-zero, the incremented array y must contain + ++ the n-element vector y. On exit, y is overwritten by the + ++ updated vector y. + ++ \item {incy}: increment for the elements of y. + ++ \end{items} + + symv: (CHAR,R,M,V,R,V) -> Void + ++ symv(uplo,alpha,A,x,beta,y) performs the matrix-vector operation + ++ y := alpha*A*x + beta*y, + ++ where alpha and beta are scalars, x and y are n-element vectors and + ++ A is an n by n symmetric matrix. + ++ Parameters: + ++ \begin{items} + ++ \item {uplo}: on entry, uplo specifies whether the upper or lower + ++ triangular part of the array A is to be referenced as + ++ follows: + ++ uplo = 'U' or 'u' only the upper triangular part of A + ++ is to be referenced. + ++ uplo = 'L' or 'l' only the lower triangular part of A + ++ is to be referenced. + ++ Unchanged on exit. + ++ \item {alpha}: on entry, specifies the scalar alpha. + ++ Unchanged on exit. + ++ \item {A}: before entry with uplo = 'U' or 'u', the + ++ upper triangular part of the array A must contain the upper + ++ triangular part of the symmetric matrix and the strictly + ++ lower triangular part of A is not referenced. + ++ Before entry with uplo = 'L' or 'l', the + ++ lower triangular part of the array A must contain the lower + ++ triangular part of the symmetric matrix and the strictly + ++ upper triangular part of A is not referenced. + ++ Unchanged on exit. + ++ \item {x}: array of dimension at least n. + ++ Before entry, the array x must contain the + ++ n-element vector x. Unchanged on exit. + ++ \item {beta}: on entry, beta specifies the scalar beta. When beta is + ++ supplied as zero then y need not be set on input. Unchanged on exit. + ++ \item {y}: array of dimension at least n. + ++ Before entry with beta non-zero, the array y must contain + ++ the n-element vector y. On exit, y is overwritten by the + ++ updated vector y. + ++ \end{items} + + syr: (CHAR,SI,R,V,SI,M,SI) -> Void + ++ syr(uplo,n,alpha,x,incx,A,lda) performs the symmetric rank 1 operation + ++ A := alpha*x*x' + A, + ++ where alpha is a scalar, x is an n-element vector and A is an + ++ n by n symmetric matrix. + ++ Parameters: + ++ \begin{items} + ++ \item {uplo}: on entry, uplo specifies whether the upper or lower + ++ triangular part of the array A is to be referenced as + ++ follows: + ++ uplo = 'U' or 'u' only the upper triangular part of A + ++ is to be referenced. + ++ uplo = 'L' or 'l' only the lower triangular part of A + ++ is to be referenced. + ++ Unchanged on exit. + ++ \item {n}: on entry, specifies the order of the matrix A. + ++ n must be at least zero. Unchanged on exit. + ++ \item {alpha}: on entry, specifies the scalar alpha. + ++ Unchanged on exit. + ++ \item {x}: array of dimension at least ( 1 + ( n - 1 )*abs( incx ) ). + ++ Before entry, the incremented array x must contain the + ++ n-element vector x. + ++ Unchanged on exit. + ++ \item {incx}: increment for the elements of x. + ++ \item {A}: before entry with uplo = 'U' or 'u', the leading n by n + ++ upper triangular part of the array A must contain the upper + ++ triangular part of the symmetric matrix and the strictly + ++ lower triangular part of A is not referenced. On exit, the + ++ upper triangular part of the array A is overwritten by the + ++ upper triangular part of the updated matrix. + ++ Before entry with uplo = 'L' or 'l', the leading n by n + ++ lower triangular part of the array A must contain the lower + ++ triangular part of the symmetric matrix and the strictly + ++ upper triangular part of A is not referenced. On exit, the + ++ lower triangular part of the array A is overwritten by the + ++ lower triangular part of the updated matrix. + ++ \item {lda}: on entry, specifies the first dimension of A as declared + ++ in the calling (sub) program. lda must be at least max( 1, n ). + ++ Unchanged on exit. + ++ \end{items} + + syr: (CHAR,R,V,M) -> Void + ++ syr(uplo,alpha,x,A) performs the symmetric rank 1 operation + ++ A := alpha*x*x' + A, + ++ where alpha is a scalar, x is an n-element vector and A is an + ++ n by n symmetric matrix. + ++ Parameters: + ++ \begin{items} + ++ \item {uplo}: on entry, uplo specifies whether the upper or lower + ++ triangular part of the array A is to be referenced as + ++ follows: + ++ uplo = 'U' or 'u' only the upper triangular part of A + ++ is to be referenced. + ++ uplo = 'L' or 'l' only the lower triangular part of A + ++ is to be referenced. + ++ Unchanged on exit. + ++ \item {alpha}: on entry, specifies the scalar alpha. + ++ Unchanged on exit. + ++ \item {x}: array of dimension at least ( 1 + ( n - 1 )*abs( incx ) ). + ++ Before entry, the array x must contain the n-element vector x. + ++ Unchanged on exit. + ++ \item {A}: before entry with uplo = 'U' or 'u', the + ++ upper triangular part of the array A must contain the upper + ++ triangular part of the symmetric matrix and the strictly + ++ lower triangular part of A is not referenced. On exit, the + ++ upper triangular part of the array A is overwritten by the + ++ upper triangular part of the updated matrix. + ++ Before entry with uplo = 'L' or 'l', the + ++ lower triangular part of the array A must contain the lower + ++ triangular part of the symmetric matrix and the strictly + ++ upper triangular part of A is not referenced. On exit, the + ++ lower triangular part of the array A is overwritten by the + ++ lower triangular part of the updated matrix. + ++ \end{items} + + syr2: (CHAR,SI,R,V,SI,V,SI,M,SI) -> Void + ++ syr2(uplo,n,alpha,x,incx,y,incy,A,lda) + ++ performs the symmetric rank 2 operation + ++ A := alpha*x*y' + alpha*y*x' + A, + ++ where alpha is a scalar, x and y are n-element vectors and A is an n + ++ by n symmetric matrix. + ++ Parameters: + ++ \begin{items} + ++ \item {uplo}: on entry, uplo specifies whether the upper or lower + ++ triangular part of the array A is to be referenced as + ++ follows: + ++ uplo = 'U' or 'u' only the upper triangular part of A + ++ is to be referenced. + ++ uplo = 'L' or 'l' only the lower triangular part of A + ++ is to be referenced. + ++ Unchanged on exit. + ++ \item {n}: on entry, specifies the order of the matrix A. + ++ n must be at least zero. Unchanged on exit. + ++ \item {alpha}: on entry, specifies the scalar alpha. + ++ Unchanged on exit. + ++ \item {x}: array of dimension at least ( 1 + ( n - 1 )*abs( incx ) ). + ++ Before entry, the incremented array x must contain the + ++ n-element vector x. + ++ Unchanged on exit. + ++ \item {incx}: increment for the elements of x. + ++ \item {y}: array of dimension at least ( 1 + ( n - 1 )*abs( incy ) ). + ++ Before entry, the incremented array y must contain the + ++ n-element vector y. + ++ Unchanged on exit. + ++ \item {incy}: increment for the elements of y. + ++ \item {A}: before entry with uplo = 'U' or 'u', the leading n by n + ++ upper triangular part of the array A must contain the upper + ++ triangular part of the symmetric matrix and the strictly + ++ lower triangular part of A is not referenced. On exit, the + ++ upper triangular part of the array A is overwritten by the + ++ upper triangular part of the updated matrix. + ++ Before entry with uplo = 'L' or 'l', the leading n by n + ++ lower triangular part of the array A must contain the lower + ++ triangular part of the symmetric matrix and the strictly + ++ upper triangular part of A is not referenced. On exit, the + ++ lower triangular part of the array A is overwritten by the + ++ lower triangular part of the updated matrix. + ++ \item {lda}: on entry, specifies the first dimension of A as declared + ++ in the calling (sub) program. lda must be at least max( 1, n ). + ++ Unchanged on exit. + ++ \end{items} + + syr2: (CHAR,R,V,V,M) -> Void + ++ syr2(uplo,alpha,x,y,A) performs the symmetric rank 2 operation + ++ A := alpha*x*y' + alpha*y*x' + A, + ++ where alpha is a scalar, x and y are n-element vectors and A is an n + ++ by n symmetric matrix. + ++ Parameters: + ++ \begin{items} + ++ \item {uplo}: on entry, uplo specifies whether the upper or lower + ++ triangular part of the array A is to be referenced as + ++ follows: + ++ uplo = 'U' or 'u' only the upper triangular part of A + ++ is to be referenced. + ++ uplo = 'L' or 'l' only the lower triangular part of A + ++ is to be referenced. + ++ Unchanged on exit. + ++ \item {n}: on entry, specifies the order of the matrix A. + ++ n must be at least zero. Unchanged on exit. + ++ \item {alpha}: on entry, specifies the scalar alpha. + ++ Unchanged on exit. + ++ \item {x}: array of dimension at least n. + ++ Before entry, the array x must contain the n-element vector x. + ++ Unchanged on exit. + ++ \item {y}: array of dimension at least n. + ++ Before entry, the array y must contain the n-element vector y. + ++ Unchanged on exit. + ++ \item {A}: before entry with uplo = 'U' or 'u', the leading n by n + ++ upper triangular part of the array A must contain the upper + ++ triangular part of the symmetric matrix and the strictly + ++ lower triangular part of A is not referenced. On exit, the + ++ upper triangular part of the array A is overwritten by the + ++ upper triangular part of the updated matrix. + ++ Before entry with uplo = 'L' or 'l', the leading n by n + ++ lower triangular part of the array A must contain the lower + ++ triangular part of the symmetric matrix and the strictly + ++ upper triangular part of A is not referenced. On exit, the + ++ lower triangular part of the array A is overwritten by the + ++ lower triangular part of the updated matrix. + ++ \end{items} + + trmv: (CHAR,CHAR,CHAR,SI,M,SI,V,SI) -> Void + ++ trmv(uplo,trans,diag,n,A,lda,x,incx) + ++ performs one of the matrix-vector operations + ++ x := A*x, or x := A'*x, + ++ where x is an n-element vector and A is an n by n unit, or non-unit, + ++ upper or lower triangular matrix. + ++ Parameters: + ++ \begin{items} + ++ \item {uplo}: on entry, specifies whether the matrix is an upper or + ++ lower triangular matrix as follows: + ++ uplo = 'U' or 'u' A is an upper triangular matrix. + ++ uplo = 'L' or 'l' A is a lower triangular matrix. + ++ Unchanged on exit. + ++ \item {trans}: on entry, specifies the operation to be performed as + ++ follows: + ++ trans = 'N' or 'n' x := A*x. + ++ trans = 'T' or 't' x := A'*x. + ++ Unchanged on exit. + ++ \item {diag}: on entry, specifies whether or not A is unit + ++ triangular as follows: + ++ diag = 'U' or 'u' A is assumed to be unit triangular. + ++ diag = 'N' or 'n' A is not assumed to be unit triangular. + ++ Unchanged on exit + ++ \item {n}: on entry, specifies the order of the matrix A. + ++ n must be at least zero. Unchanged on exit. + ++ \item {A}: before entry with uplo = 'U' or 'u', the leading n by n + ++ upper triangular part of the array A must contain the upper + ++ triangular matrix and the strictly lower triangular part of + ++ A is not referenced. + ++ Before entry with uplo = 'L' or 'l', the leading n by n + ++ lower triangular part of the array A must contain the lower triangular + ++ matrix and the strictly upper triangular part of A is not referenced. + ++ Note that when diag = 'U' or 'u', the diagonal elements of A are not + ++ referenced either, but are assumed to be unity. Unchanged on exit. + ++ \item {lda}: on entry, specifies the first dimension of A as declared + ++ in the calling (sub) program. lda must be at least max( 1, n ). + ++ Unchanged on exit. + ++ \item {x}: array of dimension at least ( 1 + ( n - 1 )*abs( incx ) ). + ++ Before entry, the incremented array x must contain the + ++ n-element vector x. + ++ On exit, x is overwritten with the tranformed vector x. + ++ \item {incx}: increment for the elements of x. + ++ \end{items} + + trmv: (CHAR,CHAR,CHAR,M,V) -> Void + ++ trmv(uplo,trans,diag,A,x) performs one of the matrix-vector operations + ++ x := A*x, or x := A'*x, + ++ where x is an n-element vector and A is an n by n unit, or non-unit, + ++ upper or lower triangular matrix. + ++ Parameters: + ++ \begin{items} + ++ \item {uplo}: on entry, specifies whether the matrix is an upper or + ++ lower triangular matrix as follows: + ++ uplo = 'U' or 'u' A is an upper triangular matrix. + ++ uplo = 'L' or 'l' A is a lower triangular matrix. + ++ Unchanged on exit. + ++ \item {trans}: on entry, specifies the operation to be performed as + ++ follows: + ++ trans = 'N' or 'n' x := A*x. + ++ trans = 'T' or 't' x := A'*x. + ++ Unchanged on exit. + ++ \item {diag}: on entry, specifies whether or not A is unit + ++ triangular as follows: + ++ diag = 'U' or 'u' A is assumed to be unit triangular. + ++ diag = 'N' or 'n' A is not assumed to be unit triangular. + ++ Unchanged on exit + ++ \item {A}: before entry with uplo = 'U' or 'u', the + ++ upper triangular part of the array A must contain the upper + ++ triangular matrix and the strictly lower triangular part of + ++ A is not referenced. Before entry with uplo = 'L' or 'l', the + ++ lower triangular part of the array A must contain the lower triangular + ++ matrix and the strictly upper triangular part of A is not referenced. + ++ Note that when diag = 'U' or 'u', the diagonal elements of A are not + ++ referenced either, but are assumed to be unity. Unchanged on exit. + ++ \item {x}: array of dimension at least n. + ++ Before entry, the array x must contain the n-element vector x. + ++ On exit, x is overwritten with the tranformed vector x. + ++ \end{items} + + trsv: (CHAR,CHAR,CHAR,SI,M,SI,V,SI) -> Void + ++ trsv(uplo,trans,diag,n,A,lda,x,incx) + ++ solves one of the systems of equations + ++ A*x = b, or A'*x = b, + ++ where b and x are n-element vectors and A is an n by n unit, or + ++ non-unit, upper or lower triangular matrix. + ++ No test for singularity or near-singularity is included in this + ++ routine. Such tests must be performed before calling this routine. + ++ Parameters: + ++ \begin{items} + ++ \item {uplo}: on entry, specifies whether the matrix is an upper or + ++ lower triangular matrix as follows: + ++ uplo = 'U' or 'u' A is an upper triangular matrix. + ++ uplo = 'L' or 'l' A is a lower triangular matrix. + ++ Unchanged on exit. + ++ \item {trans}: on entry, specifies the equations to be solved as + ++ follows: + ++ trans = 'N' or 'n' A*x = b. + ++ trans = 'T' or 't' A'*x = b. + ++ Unchanged on exit. + ++ \item {diag}: on entry, specifies whether or not A is unit + ++ triangular as follows: + ++ diag = 'U' or 'u' A is assumed to be unit triangular. + ++ diag = 'N' or 'n' A is not assumed to be unit triangular. + ++ Unchanged on exit + ++ \item {n}: on entry, specifies the order of the matrix A. + ++ n must be at least zero. Unchanged on exit. + ++ \item {A}: before entry with uplo = 'U' or 'u', the leading n by n + ++ upper triangular part of the array A must contain the upper + ++ triangular matrix and the strictly lower triangular part of + ++ A is not referenced. Before entry with uplo = 'L' or 'l', + ++ the leading n by n + ++ lower triangular part of the array A must contain the lower triangular + ++ matrix and the strictly upper triangular part of A is not referenced. + ++ Note that when diag = 'U' or 'u', the diagonal elements of A are not + ++ referenced either, but are assumed to be unity. Unchanged on exit. + ++ \item {lda}: on entry, specifies the first dimension of A as declared + ++ in the calling (sub) program. lda must be at least max( 1, n ). + ++ Unchanged on exit. + ++ \item {x}: array of dimension at least ( 1 + ( n - 1 )*abs( incx ) ). + ++ Before entry, the incremented array x must contain the + ++ n-element right-hand side vector b. On exit, x is overwritten + ++ with the solution vector x. + ++ \item {incx}: increment for the elements of x. + ++ \end{items} + + trsv: (CHAR,CHAR,CHAR,M,V) -> Void + ++ trsv(uplo,trans,diag,A,x) solves one of the systems of equations + ++ A*x = b, or A'*x = b, + ++ where b and x are n-element vectors and A is an n by n unit, or + ++ non-unit, upper or lower triangular matrix. + ++ No test for singularity or near-singularity is included in this + ++ routine. Such tests must be performed before calling this routine. + ++ Parameters: + ++ \begin{items} + ++ \item {uplo}: on entry, specifies whether the matrix is an upper or + ++ lower triangular matrix as follows: + ++ uplo = 'U' or 'u' A is an upper triangular matrix. + ++ uplo = 'L' or 'l' A is a lower triangular matrix. + ++ Unchanged on exit. + ++ \item {trans}: on entry, specifies the equations to be solved as + ++ follows: + ++ trans = 'N' or 'n' A*x = b. + ++ trans = 'T' or 't' A'*x = b. + ++ Unchanged on exit. + ++ \item {diag}: on entry, specifies whether or not A is unit + ++ triangular as follows: + ++ diag = 'U' or 'u' A is assumed to be unit triangular. + ++ diag = 'N' or 'n' A is not assumed to be unit triangular. + ++ Unchanged on exit + ++ \item {A}: before entry with uplo = 'U' or 'u', the + ++ upper triangular part of the array A must contain the upper + ++ triangular matrix and the strictly lower triangular part of + ++ A is not referenced. Before entry with uplo = 'L' or 'l', the + ++ lower triangular part of the array A must contain the lower triangular + ++ matrix and the strictly upper triangular part of A is not referenced. + ++ Note that when diag = 'U' or 'u', the diagonal elements of A are not + ++ referenced either, but are assumed to be unity. Unchanged on exit. + ++ \item {x}: array of dimension at least n. + ++ Before entry, the array x must contain the + ++ n-element right-hand side vector b. On exit, x is overwritten + ++ with the solution vector x. + ++ \end{items} + + Implementation == add + + gemv(trans:CHAR,m:SI,n:SI,alpha:R,A:M,lda:SI,x:V,incx:SI,beta:R,y:V,incy:SI): Void == + DGEMV(trans,m,n,alpha,A,lda,x,incx,beta,y,incy)$Lisp + + gemv(trans:CHAR,alpha:R,A:M,x:V,beta:R,y:V): Void == + m := nrows(A)::SI + n := ncols(A)::SI + nx := #x + ny := #y + if ((trans = char "N") or (trans = char "n")) then + nx < n => + error "gemv: #x must be at least ncols(A)" + ny < m => + error "gemv: #y must be at least nrows(A)" + else if ((trans = char "T") or (trans = char "t")) then + nx < m => + error "gemv: #x must be at least nrows(A)" + ny < n => + error "gemv: #y must be at least ncols(A)" + else + error "gemv: trans must be one of the following values: N, n, T or t" + DGEMV(trans,m,n,alpha,A,m,x,1$SI,beta,y,1$SI)$Lisp + + ger(m:SI,n:SI,alpha:R,x:V,incx:SI,y:V,incy:SI,A:M,lda:SI): Void == + DGER(m,n,alpha,x,incx,y,incy,A,lda)$Lisp + + ger(alpha:R,x:V,y:V,A:M): Void == + m := nrows(A)::SI + n := ncols(A)::SI + #x < m => + error "gemv: #x must be at least nrows(A)" + #y < n => + error "gemv: #y must be at least ncols(A)" + DGER(m,n,alpha,x,1$SI,y,1$SI,A,m)$Lisp + + symv(uplo:CHAR,n:SI,alpha:R,A:M,lda:SI,x:V,incx:SI,beta:R,y:V,incy:SI): Void == + DSYMV(uplo,n,alpha,A,lda,x,incx,beta,y,incy)$Lisp + + symv(uplo:CHAR,alpha:R,A:M,x:V,beta:R,y:V): Void == + (n := nrows(A)::SI) < ncols(A) => + error "symv: nrows(A) must be at least ncols(A)" + (#x < n) => + error "symv: #x must be at least nrows(A)" + (#y < n) => + error "symv: #y must be at least nrows(A)" + (uplo ~= char "U") and (uplo ~= char "u") and (uplo ~= char "L") and_ + (uplo ~= char "l") => + error "symv: uplo must be one of the following values: u, U, l or L" + DSYMV(uplo,n,alpha,A,n,x,1$SI,beta,y,1$SI)$Lisp + + syr(uplo:CHAR,n:SI,alpha:R,x:V,incx:SI,A:M,lda:SI): Void == + DSYR(uplo,n,alpha,x,incx,A,lda)$Lisp + + syr(uplo:CHAR,alpha:R,x:V,A:M): Void == + (n := nrows(A)::SI) < ncols(A) => + error "syr: nrows(A) must be at least ncols(A)" + (#x < n) => + error "syr: #x must be at least nrows(A)" + (uplo ~= char "U") and (uplo ~= char "u") and (uplo ~= char "L") and_ + (uplo ~= char "l") => + error "syr: uplo must be one of the following values: u, U, l or L" + DSYR(uplo,n,alpha,x,1$SI,A,n)$Lisp + + syr2(uplo:CHAR,n:SI,alpha:R,x:V,incx:SI,y:V,incy:SI,A:M,lda:SI): Void == + DSYR2(uplo,n,alpha,x,incx,y,incy,A,lda)$Lisp + + syr2(uplo:CHAR,alpha:R,x:V,y:V,A:M): Void == + (n := nrows(A)::SI) < ncols(A) => + error "syr2: nrows(A) must be at least ncols(A)" + (#x < n) => + error "syr2: #x must be at least nrows(A)" + (#y < n) => + error "syr2: #y must be at least nrows(A)" + (uplo ~= char "U") and (uplo ~= char "u") and (uplo ~= char "L") and_ + (uplo ~= char "l") => + error "syr2: uplo must be one of the following values: u, U, l or L" + DSYR2(uplo,n,alpha,x,1$SI,A,n)$Lisp + + trmv(uplo:CHAR,trans:CHAR,diag:CHAR,n:SI,A:M,lda:SI,x:V,incx:SI): Void == + DTRMV(uplo,trans,diag,n,A,lda,x,incx)$Lisp + + trmv(uplo:CHAR,trans:CHAR,diag:CHAR,A:M,x:V): Void == + (n := nrows(A)::SI) < ncols(A) => + error "trmv: nrows(A) must be at least ncols(A)" + (#x < n) => + error "trmv: #x must be at least nrows(A)" + (trans ~= char "N") and (trans ~= char "n") and (trans ~= char "T") and_ + (trans ~= char "t") => + error "trmv: trans must be one of the following values: N, n, T or t" + (uplo ~= char "U") and (uplo ~= char "u") and (uplo ~= char "L") and_ + (uplo ~= char "l") => + error "trmv: uplo must be one of the following values: u, U, l or L" + (diag ~= char "N") and (diag ~= char "n") and (diag ~= char "U") and_ + (diag ~= char "u") => + error "trmv: diag must be one of the following values: N, n, U or u" + DTRMV(uplo,trans,diag,n,A,n,x,1$SI)$Lisp + + trsv(uplo:CHAR,trans:CHAR,diag:CHAR,n:SI,A:M,lda:SI,x:V,incx:SI): Void == + DTRSV(uplo,trans,diag,n,A,lda,x,incx)$Lisp + + trsv(uplo:CHAR,trans:CHAR,diag:CHAR,A:M,x:V): Void == + (n := nrows(A)::SI) < ncols(A) => + error "trsv: nrows(A) must be at least ncols(A)" + (#x < n) => + error "trsv: #x must be at least nrows(A)" + (trans ~= char "N") and (trans ~= char "n") and (trans ~= char "T") and_ + (trans ~= char "t") => + error "trsv: trans must be one of the following values: N, n, T or t" + (uplo ~= char "U") and (uplo ~= char "u") and (uplo ~= char "L") and_ + (uplo ~= char "l") => + error "trsv: uplo must be one of the following values: u, U, l or L" + (diag ~= char "N") and (diag ~= char "n") and (diag ~= char "U") and_ + (diag ~= char "u") => + error "trsv: diag must be one of the following values: N, n, U or u" + DTRSV(uplo,trans,diag,n,A,n,x,1$SI)$Lisp + +@ +<>= +"BLAS2" [color="#FF4488",href="bookvol10.4.pdf#nameddest=BLAS2"] +"FS" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FS"] +"ACF" [color="#4488FF",href="bookvol10.2.pdf#nameddest=ACF"] +"BLAS2" -> "FS" +"BLAS2" -> "ACF" + +@ + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{package BLAS3 BlasLevelThree} +\pagehead{BlasLevelThree}{BLAS3} +%\pagepic{ps/v104blaslevelthree.ps}{BLAS3}{1.00} + +{\bf Exports:}\\ +\begin{tabular}{lllll} +\cross{BLAS3}{?**?} & +\end{tabular} + +<>= +)abbrev package BLAS3 BlasLevelThree +++ Author: Gregory Vanuxem +++ Date Created: 2006 +++ Date Last Updated: Sep 9, 2006 +++ Basic Operations: +++ Related Domains: ColumnMajorTwoDimensionnalArray +++ Also See: +++ AMS Classifications: +++ Keywords: +++ Examples: +++ References: +++ Description: +++ This package provides an interface to the +++ Blas library (level 3) +-- TODO: "at least" verification +BlasLevelThree(Row,Col,M) : Exports == Implementation where + + R ==> DoubleFloat + SI ==> SingleInteger + CHAR ==> Character + Row : OneDimensionalArrayAggregate(R) with contiguousStorage + Col : OneDimensionalArrayAggregate(R) with contiguousStorage + M : ColumnMajorTwoDimensionalArrayCategory(R,Row,Col) + + Exports == with + + gemm: (CHAR,CHAR,SI,SI,SI,R,M,SI,M,SI,R,M,SI) -> Void + ++ gemm(transa,transb,m,n,k,alpha,A,lda,B,ldb,beta,C,ldc) performs one + ++ of the matrix-matrix operations + ++ C := alpha*op( A )*op( B ) + beta*C, + ++ where op( X ) is one of + ++ op( X ) = X or op( X ) = X', + ++ alpha and beta are scalars, and A, B and C are matrices, with op( A ) + ++ an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. + ++ Parameters: + ++ \begin{items} + ++ \item {transa}: on entry, specifies the form of op( A ) to be used in + ++ the matrix multiplication as follows: + ++ transa = 'N' or 'n', op( A ) = A. + ++ transa = 'T' or 't', op( A ) = A'. + ++ Unchanged on exit. + ++ \item{transb}: on entry, specifies the form of op( B ) to be used in + ++ the matrix multiplication as follows: + ++ transb = 'N' or 'n', op( B ) = B. + ++ transb = 'T' or 't', op( B ) = B'. + ++ Unchanged on exit. + ++ \item{m}: on entry, specifies the number of rows of the matrix + ++ op( A ) and of the matrix C. m must be at least zero. + ++ Unchanged on exit. + ++ \item{n}: on entry, specifies the number of columns of the matrix + ++ op( B ) and the number of columns of the matrix C. n must be + ++ at least zero. Unchanged on exit. + ++ \item{k}: on entry, specifies the number of columns of the matrix + ++ op( A ) and the number of rows of the matrix op( B ). k must + ++ be at least zero. Unchanged on exit. + ++ \item{alpha}: on entry, specifies the scalar alpha. + ++ Unchanged on exit. + ++ \item{A}: before entry with transa = 'N' or 'n', the leading m by k + ++ part of the array A must contain the matrix A, otherwise + ++ the leading k by m part of the array A must contain the + ++ matrix A. Unchanged on exit + ++ \item{lda}: on entry, specifies the first dimension of A as declared + ++ in the calling (sub) program. When transa = 'N' or 'n' then + ++ lda must be at least max( 1, m ), otherwise lda must be at + ++ least max( 1, k ). Unchanged on exit + ++ \item{B}: before entry with transb = 'N' or 'n', + ++ the leading k by n + ++ part of the array B must contain the matrix B, otherwise + ++ the leading n by k part of the array B must contain the + ++ matrix B. Unchanged on exit. + ++ \item{ldb}: on entry, specifies the first dimension of B as declared + ++ in the calling (sub) program. When transb = 'N' or 'n' then + ++ ldb must be at least max( 1, k ), otherwise ldb must be at + ++ least max( 1, n ). Unchanged on exit. + ++ \item{beta}: on entry, specifies the scalar beta. When beta is + ++ supplied as zero then C need not be set on input. Unchanged on exit. + ++ \item{C}: before entry, the leading m by n part of the array C must + ++ contain the matrix C, except when beta is zero, in which + ++ case C need not be set on entry. + ++ On exit, the array C is overwritten by the m by n matrix + ++ ( alpha*op( A )*op( B ) + beta*C ). + ++ \item{ldc}: on entry, specifies the first dimension of C as declared + ++ in the calling (sub) program. ldc must be at least + ++ max( 1, m ). Unchanged on exit. + ++ \end{items} + + gemm: (CHAR,CHAR,R,M,M,R,M) -> Void + ++ gemm(transa,transb,alpha,A,B,beta,C) performs one + ++ of the matrix-matrix operations + ++ C := alpha*op( A )*op( B ) + beta*C, + ++ where op( X ) is one of + ++ op( X ) = X or op( X ) = X', + ++ alpha and beta are scalars, and A, B and C are matrices, with op( A ) + ++ an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. + ++ Parameters: + ++ \begin{items} + ++ \item {transa}: on entry, specifies the form of op( A ) to be used in + ++ the matrix multiplication as follows: + ++ transa = 'N', op( A ) = A. + ++ transa = 'T', op( A ) = A'. + ++ Unchanged on exit. + ++ \item{transb}: on entry, specifies the form of op( B ) to be used in + ++ the matrix multiplication as follows: + ++ transb = 'N', op( B ) = B. + ++ transb = 'T', op( B ) = B'. + ++ Unchanged on exit. + ++ \item{alpha}: on entry, specifies the scalar alpha. + ++ Unchanged on exit. + ++ \item{A}: before entry with transa = 'N' or 'n', the leading m by k + ++ part of the array A must contain the matrix A, otherwise + ++ the leading k by m part of the array A must contain the + ++ matrix A. Unchanged on exit + ++ \item{B}: before entry with transb = 'N' or 'n', + ++ the leading k by n + ++ part of the array B must contain the matrix B, otherwise + ++ the leading n by k part of the array B must contain the + ++ matrix B. Unchanged on exit. + ++ \item{beta}: on entry, specifies the scalar beta. When beta is + ++ supplied as zero then C need not be set on input. Unchanged on exit. + ++ \item{C}: before entry, the leading m by n part of the array C must + ++ contain the matrix C, except when beta is zero, in which + ++ case C need not be set on entry. + ++ On exit, the array C is overwritten by the m by n matrix + ++ ( alpha*op( A )*op( B ) + beta*C ). + ++ \end{items} + + symm: (CHAR,CHAR,SI,SI,R,M,SI,M,SI,R,M,SI) -> Void + ++ symm(side,uplo,m,n,alpha,A,lda,B,ldb,beta,C,ldc) performs one of + ++ the matrix-matrix operations + ++ C := alpha*A*B + beta*C, or C := alpha*B*A + beta*C, + ++ where alpha and beta are scalars, A is a symmetric matrix and B and + ++ C are m by n matrices. + ++ Parameters: + ++ \begin{items} + ++ \item {side}: on entry, specifies whether the symmetric matrix A + ++ appears on the left or right in the operation as follows: + ++ side = 'L' or 'l' C := alpha*A*B + beta*C, + ++ side = 'R' or 'r' C := alpha*B*A + beta*C, + ++ Unchanged on exit. + ++ \item{uplo}: on entry, specifies whether the upper or lower + ++ triangular part of the symmetric matrix A is to be + ++ referenced as follows: + ++ uplo = 'U' or 'u' Only the upper triangular part of the + ++ symmetric matrix is to be referenced. + ++ uplo = 'L' or 'l' Only the lower triangular part of the + ++ symmetric matrix is to be referenced. + ++ Unchanged on exit. + ++ \item{m}: on entry, specifies the number of rows of the matrix C. + ++ m must be at least zero. Unchanged on exit. + ++ \item{n}: on entry, specifies the number of columns of the matrix C. + ++ n must be at least zero. Unchanged on exit. + ++ \item{alpha}: on entry, specifies the scalar alpha. + ++ Unchanged on exit. + ++ \item{A}: before entry with side = 'L' or 'l', the m by m part of + ++ the array A must contain the symmetric matrix, such that + ++ when uplo = 'U' or 'u', the leading m by m upper triangular + ++ part of the array A must contain the upper triangular part + ++ of the symmetric matrix and the strictly lower triangular + ++ part of A is not referenced, and when uplo = 'L' or 'l', + ++ the leading m by m lower triangular part of the array A + ++ must contain the lower triangular part of the symmetric + ++ matrix and the strictly upper triangular part of A is not + ++ referenced. + ++ Before entry with side = 'R' or 'r', the n by n part of + ++ the array A must contain the symmetric matrix, such that + ++ when uplo = 'U' or 'u', the leading n by n upper triangular + ++ part of the array A must contain the upper triangular part + ++ of the symmetric matrix and the strictly lower triangular + ++ part of A is not referenced, and when uplo = 'L' or 'l', + ++ the leading n by n lower triangular part of the array A + ++ must contain the lower triangular part of the symmetric + ++ matrix and the strictly upper triangular part of A is not + ++ referenced. Unchanged on exit. + ++ \item{lda}: on entry, specifies the first dimension of A as declared + ++ in the calling (sub) program. When side = 'L' or 'l' then + ++ lda must be at least max( 1, m ), otherwise lda must be at + ++ least max( 1, n ). Unchanged on exit. + ++ \item{B}: Before entry, the leading m by n part of the array B must + ++ contain the matrix B. Unchanged on exit. + ++ \item{ldb}: on entry, ldb specifies the first dimension of B as + ++ declared in the calling (sub) program. ldb must be at + ++ least max( 1, m ). + ++ Unchanged on exit. + ++ \item{beta}: on entry, specifies the scalar beta. When beta is + ++ supplied as zero then C need not be set on input. Unchanged on exit. + ++ \item{C}: before entry, the leading m by n part of the array C must + ++ contain the matrix C, except when beta is zero, in which + ++ case C need not be set on entry. On exit, the array C is + ++ overwritten by the m by n updated matrix. + ++ \item{ldc}: on entry, specifies the first dimension of C as declared + ++ in the calling (sub) program. ldc must be at least + ++ max( 1, m ). Unchanged on exit. + ++ \end{items} + + symm: (CHAR,CHAR,R,M,M,R,M) -> Void + ++ symm(side,uplo,alpha,A,B,beta,C) performs one of + ++ the matrix-matrix operations + ++ C := alpha*A*B + beta*C, or C := alpha*B*A + beta*C, + ++ where alpha and beta are scalars, A is a symmetric matrix and B and + ++ C are m by n matrices. + ++ Parameters: + ++ \begin{items} + ++ \item {side}: on entry, specifies whether the symmetric matrix A + ++ appears on the left or right in the operation as follows: + ++ side = 'L' or 'l' C := alpha*A*B + beta*C, + ++ side = 'R' or 'r' C := alpha*B*A + beta*C, + ++ Unchanged on exit. + ++ \item{uplo}: on entry, specifies whether the upper or lower + ++ triangular part of the symmetric matrix A is to be + ++ referenced as follows: + ++ uplo = 'U' or 'u' Only the upper triangular part of the + ++ symmetric matrix is to be referenced. + ++ uplo = 'L' or 'l' Only the lower triangular part of the + ++ symmetric matrix is to be referenced. + ++ Unchanged on exit. + ++ \item{alpha}: on entry, specifies the scalar alpha. + ++ Unchanged on exit. + ++ \item{A}: before entry with side = 'L' or 'l', the m by m part of + ++ the array A must contain the symmetric matrix, such that + ++ when uplo = 'U' or 'u', the leading m by m upper triangular + ++ part of the array A must contain the upper triangular part + ++ of the symmetric matrix and the strictly lower triangular + ++ part of A is not referenced, and when uplo = 'L' or 'l', + ++ the leading m by m lower triangular part of the array A + ++ must contain the lower triangular part of the symmetric + ++ matrix and the strictly upper triangular part of A is not + ++ referenced. + ++ Before entry with side = 'R' or 'r', the n by n part of + ++ the array A must contain the symmetric matrix, such that + ++ when uplo = 'U' or 'u', the leading n by n upper triangular + ++ part of the array A must contain the upper triangular part + ++ of the symmetric matrix and the strictly lower triangular + ++ part of A is not referenced, and when uplo = 'L' or 'l', + ++ the leading n by n lower triangular part of the array A + ++ must contain the lower triangular part of the symmetric + ++ matrix and the strictly upper triangular part of A is not + ++ referenced. Unchanged on exit. + ++ \item{B}: Before entry, the leading m by n part of the array B must + ++ contain the matrix B. Unchanged on exit. + ++ \item{beta}: on entry, specifies the scalar beta. When beta is + ++ supplied as zero then C need not be set on input. Unchanged on exit. + ++ \item{C}: before entry, the leading m by n part of the array C must + ++ contain the matrix C, except when beta is zero, in which + ++ case C need not be set on entry. On exit, the array C is + ++ overwritten by the m by n updated matrix. + ++ \end{items} + + + syrk: (CHAR,CHAR,SI,SI,R,M,SI,R,M,SI) -> Void + ++ syrk(uplo,trans,n,k,alpha,A,lda,beta,C,ldc) performs one of + ++ the symmetric rank k operations + ++ C := alpha*A*A' + beta*C, or C := alpha*A'*A + beta*C, + ++ where alpha and beta are scalars, C is an n by n symmetric matrix + ++ and A is an n by k matrix in the first case and a k by n matrix + ++ in the second case. + ++ Parameters: + ++ \begin{items} + ++ \item{uplo}: on entry, specifies whether the upper or lower + ++ triangular part of the array C is to be referenced as + ++ follows: + ++ uplo = 'U' or 'u' Only the upper triangular part of C + ++ is to be referenced. + ++ uplo = 'L' or 'l' Only the lower triangular part of C + ++ is to be referenced. + ++ Unchanged on exit. + ++ \item{trans}: on entry, specifies the operation to be performed as + ++ follows: + ++ trans = 'N' or 'n' C := alpha*A*A' + beta*C. + ++ trans = 'T' or 't' C := alpha*A'*A + beta*C. + ++ Unchanged on exit. + ++ \item{n}: on entry, specifies the order of the matrix C. n must be + ++ at least zero. Unchanged on exit. + ++ \item{k}: on entry with trans = 'N' or 'n', k specifies the number + ++ of columns of the matrix A, and on entry with + ++ trans = 'T' or 't', k specifies the number + ++ of rows of the matrix A. K must be at least zero. Unchanged on exit. + ++ \item{alpha}: on entry, specifies the scalar alpha. + ++ Unchanged on exit. + ++ \item{A}: before entry with trans = 'N' or 'n', the leading n by k + ++ part of the array A must contain the matrix A, otherwise + ++ the leading k by n part of the array A must contain the + ++ matrix A. Unchanged on exit. + ++ \item{lda}: on entry, specifies the first dimension of A as declared + ++ in the calling (sub) program. When trans = 'N' or 'n' + ++ then lda must be at least max( 1, n ), otherwise lda must + ++ be at least max( 1, k ). Unchanged on exit. + ++ \item{beta}: on entry, specifies the scalar beta. Unchanged on exit. + ++ \item{C}: before entry with uplo = 'U' or 'u', the leading n by n + ++ upper triangular part of the array C must contain the upper + ++ triangular part of the symmetric matrix and the strictly + ++ lower triangular part of C is not referenced. On exit, the + ++ upper triangular part of the array C is overwritten by the + ++ upper triangular part of the updated matrix. + ++ Before entry with uplo = 'L' or 'l', the leading n by n + ++ lower triangular part of the array C must contain the lower + ++ triangular part of the symmetric matrix and the strictly + ++ upper triangular part of C is not referenced. On exit, the + ++ lower triangular part of the array C is overwritten by the + ++ lower triangular part of the updated matrix. + ++ \item{ldc}: on entry, specifies the first dimension of C as declared + ++ in the calling (sub) program. ldc must be at least + ++ max( 1, n ). Unchanged on exit. + ++ \end{items} + + syrk: (CHAR,CHAR,R,M,R,M) -> Void + ++ syrk(uplo,trans,alpha,A,beta,C) performs one of + ++ the symmetric rank k operations + ++ C := alpha*A*A' + beta*C, or C := alpha*A'*A + beta*C, + ++ where alpha and beta are scalars, C is an n by n symmetric matrix + ++ and A is an n by k matrix in the first case and a k by n matrix + ++ in the second case. + ++ Parameters: + ++ \begin{items} + ++ \item{uplo}: on entry, specifies whether the upper or lower + ++ triangular part of the array C is to be referenced as + ++ follows: + ++ uplo = 'U' or 'u' Only the upper triangular part of C + ++ is to be referenced. + ++ uplo = 'L' or 'l' Only the lower triangular part of C + ++ is to be referenced. + ++ Unchanged on exit. + ++ \item{trans}: on entry, specifies the operation to be performed as + ++ follows: + ++ trans = 'N' or 'n' C := alpha*A*A' + beta*C. + ++ trans = 'T' or 't' C := alpha*A'*A + beta*C. + ++ Unchanged on exit. + ++ \item{alpha}: on entry, specifies the scalar alpha. + ++ Unchanged on exit. + ++ \item{A}: before entry with trans = 'N' or 'n', the leading n by k + ++ part of the array A must contain the matrix A, otherwise + ++ the leading k by n part of the array A must contain the + ++ matrix A. Unchanged on exit. + ++ \item{beta}: on entry, specifies the scalar beta. Unchanged on exit. + ++ \item{C}: before entry with uplo = 'U' or 'u', the leading n by n + ++ upper triangular part of the array C must contain the upper + ++ triangular part of the symmetric matrix and the strictly + ++ lower triangular part of C is not referenced. On exit, the + ++ upper triangular part of the array C is overwritten by the + ++ upper triangular part of the updated matrix. + ++ Before entry with uplo = 'L' or 'l', the leading n by n + ++ lower triangular part of the array C must contain the lower + ++ triangular part of the symmetric matrix and the strictly + ++ upper triangular part of C is not referenced. On exit, the + ++ lower triangular part of the array C is overwritten by the + ++ lower triangular part of the updated matrix. + ++ \end{items} + + syr2k: (CHAR,CHAR,SI,SI,R,M,SI,M,SI,R,M,SI) -> Void + ++ syr2k(uplo,trans,n,k,alpha,A,lda,B,ldb,beta,C,ldc) performs one + ++ of the symmetric rank 2k operations + ++ C := alpha*A*B' + alpha*B*A' + beta*C, or + ++ C := alpha*A'*B + alpha*B'*A + beta*C, + ++ where alpha and beta are scalars, C is an n by n symmetric matrix + ++ and A and B are n by k matrices in the first case and k by n + ++ matrices in the second case. + ++ Parameters: + ++ \begin{items} + ++ \item{uplo}: on entry, specifies whether the upper or lower + ++ triangular part of the array C is to be referenced as + ++ follows: + ++ uplo = 'U' or 'u' Only the upper triangular part of C + ++ is to be referenced. + ++ uplo = 'L' or 'l' Only the lower triangular part of C + ++ is to be referenced. + ++ Unchanged on exit. + ++ \item{trans}: on entry, specifies the operation to be performed as + ++ follows: + ++ trans = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + beta*C. + ++ trans = 'T' or 't' C := alpha*A'*B + alpha*B'*A + beta*C. + ++ Unchanged on exit. + ++ \item{n}: on entry, specifies the order of the matrix C. n must be + ++ at least zero. Unchanged on exit. + ++ \item{k}: on entry with trans = 'N' or 'n', K specifies the number + ++ of columns of the matrices A and B, and on entry with + ++ trans = 'T' or 't' or 'C' or 'c', K specifies the number + ++ of rows of the matrices A and B. K must be at least zero. + ++ Unchanged on exit. + ++ \item{alpha}: on entry, specifies the scalar alpha. + ++ Unchanged on exit. + ++ \item{A}: before entry with trans = 'N' or 'n', the leading n by k + ++ part of the array A must contain the matrix A, otherwise + ++ the leading k by n part of the array A must contain the + ++ matrix A. Unchanged on exit. + ++ \item{lda}: on entry, specifies the first dimension of A as declared + ++ in the calling (sub) program. When trans = 'N' or 'n' + ++ then lda must be at least max( 1, n ), otherwise lda must + ++ be at least max( 1, k ). Unchanged on exit. + ++ \item{B}: before entry with trans = 'N' or 'n', the leading n by k + ++ part of the array B must contain the matrix B, otherwise + ++ the leading k by n part of the array B must contain the + ++ matrix B. Unchanged on exit. + ++ \item{ldb}: on entry, specifies the first dimension of B as declared + ++ in the calling (sub) program. When trans = 'N' or 'n' + ++ then ldb must be at least max( 1, n ), otherwise ldb must + ++ be at least max( 1, k ). Unchanged on exit. + ++ \item{beta}: on entry, specifies the scalar beta. Unchanged on exit. + ++ \item{C}: before entry with uplo = 'U' or 'u', the leading n by n + ++ upper triangular part of the array C must contain the upper + ++ triangular part of the symmetric matrix and the strictly + ++ lower triangular part of C is not referenced. On exit, the + ++ upper triangular part of the array C is overwritten by the + ++ upper triangular part of the updated matrix. + ++ Before entry with uplo = 'L' or 'l', the leading n by n + ++ lower triangular part of the array C must contain the lower + ++ triangular part of the symmetric matrix and the strictly + ++ upper triangular part of C is not referenced. On exit, the + ++ lower triangular part of the array C is overwritten by the + ++ lower triangular part of the updated matrix. + ++ \item{ldc}: on entry, specifies the first dimension of C as declared + ++ in the calling (sub) program. ldc must be at least + ++ max( 1, n ). Unchanged on exit. + ++ \end{items} + + syr2k: (CHAR,CHAR,R,M,M,R,M) -> Void + ++ syr2k(uplo,trans,alpha,A,B,beta,C) performs one + ++ of the symmetric rank 2k operations + ++ C := alpha*A*B' + alpha*B*A' + beta*C, or + ++ C := alpha*A'*B + alpha*B'*A + beta*C, + ++ where alpha and beta are scalars, C is an n by n symmetric matrix + ++ and A and B are n by k matrices in the first case and k by n + ++ matrices in the second case. + ++ Parameters: + ++ \begin{items} + ++ \item{uplo}: on entry, specifies whether the upper or lower + ++ triangular part of the array C is to be referenced as + ++ follows: + ++ uplo = 'U' or 'u' Only the upper triangular part of C + ++ is to be referenced. + ++ uplo = 'L' or 'l' Only the lower triangular part of C + ++ is to be referenced. + ++ Unchanged on exit. + ++ \item{trans}: on entry, specifies the operation to be performed as + ++ follows: + ++ trans = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + beta*C. + ++ trans = 'T' or 't' C := alpha*A'*B + alpha*B'*A + beta*C. + ++ Unchanged on exit. + ++ \item{alpha}: on entry, specifies the scalar alpha. + ++ Unchanged on exit. + ++ \item{A}: before entry with trans = 'N' or 'n', the leading n by k + ++ part of the array A must contain the matrix A, otherwise + ++ the leading k by n part of the array A must contain the + ++ matrix A. Unchanged on exit. + ++ \item{B}: before entry with trans = 'N' or 'n', the leading n by k + ++ part of the array B must contain the matrix B, otherwise + ++ the leading k by n part of the array B must contain the + ++ matrix B. Unchanged on exit. + ++ \item{beta}: on entry, specifies the scalar beta. Unchanged on exit. + ++ \item{C}: before entry with uplo = 'U' or 'u', the leading n by n + ++ upper triangular part of the array C must contain the upper + ++ triangular part of the symmetric matrix and the strictly + ++ lower triangular part of C is not referenced. On exit, the + ++ upper triangular part of the array C is overwritten by the + ++ upper triangular part of the updated matrix. + ++ Before entry with uplo = 'L' or 'l', the leading n by n + ++ lower triangular part of the array C must contain the lower + ++ triangular part of the symmetric matrix and the strictly + ++ upper triangular part of C is not referenced. On exit, the + ++ lower triangular part of the array C is overwritten by the + ++ lower triangular part of the updated matrix. + ++ \end{items} + + Implementation == add + + gemm(transa:CHAR,transb:CHAR,m:SI,n:SI,k:SI,alpha:R,A:M,lda:SI,B:M,ldb:SI,beta:R,C:M,ldc:SI): Void == + DGEMM(transa,transb,m,n,k,alpha,A,lda,B,ldb,beta,C,ldc)$Lisp + + gemm(transa:CHAR,transb:CHAR,alpha:R,A:M,B:M,beta:R,C:M): Void == + nra := nrows(A)::SI + nca := ncols(A)::SI + ldb := nrows(B)::SI + ldc := nrows(C)::SI + if transa = char "N" then + ldc < nra => error "gemm: nrows(C) must be at least nrows(A)" + if transb = char "N" then + ncopb := ncols(B)::SI + ldb < nca => error "gemm: nrows(B) must be at least ncols(A)" + ncols(C) < ncopb => error "gemm: ncols(C) must be at least ncols(B)" + DGEMM(transa,transb,nra,ncopb,nca,alpha,A,nra,B,ldb,beta,C,ldc)$Lisp + else if transb = char "T" then + ncols(B) < nca => error "gemm: ncols(B) must be at least ncols(A)" + ncols(C) < ldb => error "gemm: ncols(C) must be at least nrows(B)" + DGEMM(transa,transb,nra,ldb,nca,alpha,A,nra,B,ldb,beta,C,ldc)$Lisp + else + error "gemm: transb must be N or T" + else if transa = char "T" then + ldc < nca => error "gemm: nrows(C) must be at least ncols(A)" + if transb = char "N" then + ncopb := ncols(B)::SI + ldb < nra => error "gemm: nrows(B) must be at least nrows(A)" + ncols(C) < ncopb => error "gemm: ncols(C) must be at least ncols(B)" + DGEMM(transa,transb,nca,ncopb,nra,alpha,A,nra,B,ldb,beta,C,ldc)$Lisp + else if transb = char "T" then + ncols(B) < nra => error "gemm: ncols(B) must be at least ncols(A)" + ncols(C) < ldb => error "gemm: ncols(C) must be at least nrows(B)" + DGEMM(transa,transb,nca,ldb,nra,alpha,A,nra,B,ldb,beta,C,ldc)$Lisp + else + error "gemm: transb must be N or T" + else + error "gemm: transa must be N or T" + + symm(side:CHAR,uplo:CHAR,m:SI,n:SI,alpha:R,A:M,lda:SI,B:M,ldb:SI,beta:R,C:M,ldc:SI): Void == + DSYMM(side,uplo,m,n,alpha,A,lda,B,ldb,beta,C,ldc)$Lisp + + symm(side:CHAR,uplo:CHAR,alpha:R,A:M,B:M,beta:R,C:M): Void == + uplo ~= char "u" and uplo ~= char "U" and uplo ~= char "l" and uplo ~= char "L" + => error "symm: uplo must be one of the following values: u, U, l or L" + if side = char "l" or side = char "L" then + m := nrows(A)::SI; + n := ncols(B)::SI; + ncols(A) < m => error "symm: ncols(A) must be at least nrows(A)" + (ldb := nrows(B)::SI) < m => error "symm: nrows(B) must be at least nrows(A)" + (ldc := nrows(C)::SI) < m => error "symm: nrows(C) must be at least nrows(A)" + ncols(C) < n => error "symm: ncols(C) must be at least ncols(B)" + DSYMM(side,uplo,m,n,alpha,A,m,B,ldb,beta,C,ldc)$Lisp + else if side = char "r" or side = char "R" then + n := ncols(A)::SI; + m := nrows(B)::SI; + nrows(A) < n => error "symm: nrows(A) must be at least ncols(A)" + ncols(B) < n => error "symm: ncols(B) must be at least ncols(A)" + (ldc := nrows(C)::SI) < m => error "symm: nrows(C) must be at least nrows(B)" + ncols(C) < n => error "symm: ncols(C) must be at least ncols(A)" + DSYMM(side,uplo,m,n,alpha,A,n,B,m,beta,C,ldc)$Lisp + else + error "symm: side must be one of the following values: l, L, r or R" + + syrk(uplo:CHAR,trans:CHAR,n:SI,k:SI,alpha:R,A:M,lda:SI,beta:R,C:M,ldc:SI): Void == + DSYRK(uplo,trans,n,k,alpha,A,lda,beta,C,ldc)$Lisp + + syrk(uplo:CHAR,trans:CHAR,alpha:R,A:M,beta:R,C:M): Void == + nra := nrows(A)::SI + nca := ncols(A)::SI + uplo ~= char "u" and uplo ~= char "U" and uplo ~= char "l" and uplo ~= char "L" + => error "syrk: uplo must be one of the following values: u, U, l or L" + if trans = char "n" or trans = char "N" then + (ldc := nrows(C)::SI) < nra => error "syrk: nrows(C) must be at least nrows(A)" + ncols(C) < nra => error "syrk: ncols(C) must be at least nrows(A)" + DSYRK(uplo,trans,nra,nca,alpha,A,nra,beta,C,ldc)$Lisp + else if trans = char "t" or trans = char "T" then + (ldc := nrows(C)::SI) < nca => error "syrk: nrows(C) must be at least ncols(A)" + ncols(C) < nca => error "syrk: ncols(C) must be at least ncols(A)" + DSYRK(uplo,trans,nca,nra,alpha,A,nra,beta,C,ldc)$Lisp + else + error "syrk: trans must be one of the following values: n, N, t or T" + + syr2k(uplo:CHAR,trans:CHAR,n:SI,k:SI,alpha:R,A:M,lda:SI,B:M,ldb:SI,beta:R,C:M,ldc:SI): Void == + DSYR2K(uplo,trans,n,k,alpha,A,lda,B,ldb,beta,C,ldc)$Lisp + + syr2k(uplo:CHAR,trans:CHAR,alpha:R,A:M,B:M,beta:R,C:M): Void == + nra := nrows(A)::SI + nca := ncols(A)::SI + uplo ~= char "u" and uplo ~= char "U" and uplo ~= char "l" and uplo ~= char "L" + => error "syr2k: uplo must be one of the following values: u, U, l or L" + if trans = char "n" or trans = char "N" then + (ldb := nrows(B)::SI) < nra => error "syr2k: nrows(B) must be at least nrows(A)" + ncols(B) < nca => error "syr2k: ncols(B) must be at least ncols(A)" + (ldc := nrows(C)::SI) < nra => error "syr2k: nrows(C) must be at least nrows(A)" + ncols(C) < nra => error "syr2k: ncols(C) must be at least nrows(A)" + DSYR2K(uplo,trans,nra,nca,alpha,A,nra,B,ldb,beta,C,ldc)$Lisp + else if trans = char "t" or trans = char "T" then + (ldb := nrows(B)::SI) < nra => error "syr2k: nrows(B) must be at least nrows(A)" + ncols(B) < nca => error "syr2k: ncols(B) must be at least ncols(A)" + (ldc := nrows(C)::SI) < nca => error "syr2k: nrows(C) must be at least ncols(A)" + ncols(C) < nca => error "syr2k: ncols(C) must be at least ncols(A)" + DSYR2K(uplo,trans,nca,nra,alpha,A,nra,B,ldb,beta,C,ldc)$Lisp + else + error "syr2k: trans must be one of the following values: n, N, t or T" + + +@ +<>= +"BLAS3" [color="#FF4488",href="bookvol10.4.pdf#nameddest=BLAS3"] +"FS" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FS"] +"ACF" [color="#4488FF",href="bookvol10.2.pdf#nameddest=ACF"] +"BLAS3" -> "FS" +"BLAS3" -> "ACF" + +@ + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{package LAPACK Lapack} +\pagehead{Lapack}{LAPACK} +%\pagepic{ps/v104lapack.ps}{LAPACK}{1.00} + +{\bf Exports:}\\ +\begin{tabular}{lllll} +\cross{LAPACK}{?**?} & +\end{tabular} + +<>= +)abbrev package LAPACK Lapack +++ Author: Gregory Vanuxem +++ Date Created: 2006 +++ Date Last Updated: Nov 11, 2006 +++ Basic Operations: +++ Related Domains: ColumnMajorTwoDimensionnalArray +++ Also See: +++ AMS Classifications: +++ Keywords: +++ Examples: +++ References: +++ Description: +++ This package provides an interface to the +++ LAPack library +-- TODO: "at least" verification +Lapack(Row,Col,M) : Exports == Implementation where + + R ==> DoubleFloat + SI ==> SingleInteger + CHAR ==> Character + VSI ==> Vector(SI) -- Vector has contiguousStorage + VSF ==> Vector(R) -- Vector has contiguousStorage + Row : OneDimensionalArrayAggregate(R) with contiguousStorage + Col : OneDimensionalArrayAggregate(R) with contiguousStorage + M : ColumnMajorTwoDimensionalArrayCategory(R,Row,Col) + + Exports == with + + getrf: (SI,SI,M,SI,VSI) -> SI + ++ gemm(transa,transb,m,n,k,alpha,A,lda,B,ldb,beta,C,ldc) performs one + ++ of the matrix-matrix operations + + getri: (SI,M,SI,VSI,VSF,SI) -> SI + ++ gemm(transa,transb,m,n,k,alpha,A,lda,B,ldb,beta,C,ldc) performs one + ++ of the matrix-matrix operations + + Implementation == add + + getrf(m:SI,n:SI,A:M,lda:SI,ipiv:VSI): SI == + DGETRF(m,n,A,lda,ipiv)$Lisp + + getri(n:SI,A:M,lda:SI,ipiv:VSI,work:VSF,lwork:SI): SI == + DGETRI(n,A,lda,ipiv,work,lwork)$Lisp + +@ +<>= +"LAPACK" [color="#FF4488",href="bookvol10.4.pdf#nameddest=LAPACK"] +"FS" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FS"] +"ACF" [color="#4488FF",href="bookvol10.2.pdf#nameddest=ACF"] +"LAPACK" -> "FS" +"LAPACK" -> "ACF" + +@ + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter A} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter B} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter C} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter D} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dasum BLAS} +\pagehead{dasum}{dasum} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +Computes doublefloat $asum \leftarrow ||re(x)||_1 + ||im(x)||_1$ + +Arguments are: +\begin{itemize} +\item n - fixnum +\item dx - array doublefloat +\item incx - fixnum +\end{itemize} + +Return values are: +\begin{itemize} +\item 1 nil +\item 2 nil +\item 3 nil +\end{itemize} + +<>= +(defun dasum (n dx incx) + (declare (type (array double-float (*)) dx) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data ((dx double-float dx-%data% dx-%offset%)) + (prog ((i 0) (m 0) (mp1 0) (nincx 0) (dtemp 0.0) (dasum 0.0)) + (declare (type (double-float) dasum dtemp) + (type fixnum nincx mp1 m i)) + (setf dasum 0.0) + (setf dtemp 0.0) + (if (or (<= n 0) (<= incx 0)) (go end_label)) + (if (= incx 1) (go label20)) + (setf nincx (f2cl-lib:int-mul n incx)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i incx)) + ((> i nincx) nil) + (tagbody + (setf dtemp + (the double-float + (+ (the double-float dtemp) + (the double-float (abs + (the double-float + (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%))))))))) + (setf dasum dtemp) + (go end_label) + label20 + (setf m (mod n 6)) + (if (= m 0) (go label40)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf dtemp + (the double-float + (+ (the double-float dtemp) + (the double-float (abs + (the double-float + (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%))))))))) + (if (< n 6) (go label60)) + label40 + (setf mp1 (f2cl-lib:int-add m 1)) + (f2cl-lib:fdo (i mp1 (f2cl-lib:int-add i 6)) + ((> i n) nil) + (tagbody + (setf dtemp + (the double-float + (+ (the double-float dtemp) + (the double-float (abs + (the double-float + (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)))) + (the double-float (abs + (the double-float + (f2cl-lib:fref + dx-%data% ((f2cl-lib:int-add i 1)) ((1 *)) dx-%offset%)))) + (the double-float (abs + (the double-float + (f2cl-lib:fref + dx-%data% ((f2cl-lib:int-add i 2)) ((1 *)) dx-%offset%)))) + (the double-float (abs + (the double-float + (f2cl-lib:fref + dx-%data% ((f2cl-lib:int-add i 3)) ((1 *)) dx-%offset%)))) + (the double-float (abs + (the double-float + (f2cl-lib:fref + dx-%data% ((f2cl-lib:int-add i 4)) ((1 *)) dx-%offset%)))) + (the double-float (abs + (the double-float + (f2cl-lib:fref + dx-%data% ((f2cl-lib:int-add i 5)) ((1 *)) dx-%offset%))))))))) + label60 + (setf dasum dtemp) + end_label + (return (values dasum nil nil nil))))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{daxpy BLAS} +\pagehead{daxpy}{daxpy} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +Computes doublefloat $y \leftarrow \alpha{}x + y$ + +Arguments are: +\begin{itemize} +\item n - fixnum +\item da - doublefloat +\item dx - array doublefloat +\item incx - fixnum +\item dy - array doublefloat +\item incy - fixnum +\end{itemize} + +Return values are: +\begin{itemize} +\item 1 nil +\item 2 nil +\item 3 nil +\item 4 nil +\item 5 nil +\item 6 nil +\end{itemize} + +<>= +(defun daxpy (n da dx incx dy incy) + (declare (type (array double-float (*)) dy dx) + (type (double-float) da) + (type fixnum incy incx n)) + (f2cl-lib:with-multi-array-data + ((dx double-float dx-%data% dx-%offset%) + (dy double-float dy-%data% dy-%offset%)) + (prog ((i 0) (ix 0) (iy 0) (m 0) (mp1 0)) + (declare (type fixnum mp1 m iy ix i)) + (if (<= n 0) (go end_label)) + (if (= da 0.0) (go end_label)) + (if (and (= incx 1) (= incy 1)) (go label20)) + (setf ix 1) + (setf iy 1) + (if (< incx 0) + (setf ix + (f2cl-lib:int-add (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) 1))) + (if (< incy 0) + (setf iy + (f2cl-lib:int-add (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) 1))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%) + (+ (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%) + (* da (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (go end_label) + label20 + (setf m (mod n 4)) + (if (= m 0) (go label40)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%) + (+ (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%) + (* da (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)))))) + (if (< n 4) (go end_label)) + label40 + (setf mp1 (f2cl-lib:int-add m 1)) + (f2cl-lib:fdo (i mp1 (f2cl-lib:int-add i 4)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%) + (+ (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%) + (* da (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)))) + (setf + (f2cl-lib:fref dy-%data% ((f2cl-lib:int-add i 1)) ((1 *)) dy-%offset%) + (+ (f2cl-lib:fref + dy-%data% ((f2cl-lib:int-add i 1)) ((1 *)) dy-%offset%) + (* da (f2cl-lib:fref + dx-%data% ((f2cl-lib:int-add i 1)) ((1 *)) dx-%offset%)))) + (setf + (f2cl-lib:fref dy-%data% ((f2cl-lib:int-add i 2)) ((1 *)) dy-%offset%) + (+ (f2cl-lib:fref + dy-%data% ((f2cl-lib:int-add i 2)) ((1 *)) dy-%offset%) + (* da (f2cl-lib:fref + dx-%data% ((f2cl-lib:int-add i 2)) ((1 *)) dx-%offset%)))) + (setf + (f2cl-lib:fref dy-%data% ((f2cl-lib:int-add i 3)) ((1 *)) dy-%offset%) + (+ (f2cl-lib:fref + dy-%data% ((f2cl-lib:int-add i 3)) ((1 *)) dy-%offset%) + (* da (f2cl-lib:fref + dx-%data% ((f2cl-lib:int-add i 3)) ((1 *)) dx-%offset%)))))) + end_label + (return (values nil nil nil nil nil nil))))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dbdsdc LAPACK} +\pagehead{dbdsdc}{dbdsdc} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +The input arguments are: +\begin{itemize} +\item uplo - simple-array character (1) +\item compq - (simple-array character (1) +\item n - fixnum +\item d - array doublefloat +\item e - array doublefloat +\item u - array doublefloat +\item ldu - fixnum +\item vt - doublefloat +\item ldvt - fixnum +\item q - array doublefloat +\item iq - array fixnum +\item work - array doublefloat +\item iwork - array fixnum +\item info - fixnum +\end{itemize} + +The return values are: +\begin{itemize} +\item uplo - nil +\item compq - nil +\item n - nil +\item d - nil +\item e - nil +\item u - nil +\item ldu - nil +\item vt - nil +\item ldvt - nil +\item q - nil +\item iq - nil +\item work - nil +\item iwork - nil +\item info - info +\end{itemize} + +\calls{dbdsdc}{dlasr} +\calls{dbdsdc}{dswap} +\calls{dbdsdc}{dlasda} +\calls{dbdsdc}{dlasd0} +\calls{dbdsdc}{dlamch} +\calls{dbdsdc}{dlascl} +\calls{dbdsdc}{dlanst} +\calls{dbdsdc}{dlaset} +\calls{dbdsdc}{dlasdq} +\calls{dbdsdc}{dlartg} +\calls{dbdsdc}{dcopy} +\calls{dbdsdc}{ilaenv} +\calls{dbdsdc}{xerbla} +\calls{dbdsdc}{lsame} + +<>= +(let* ((zero 0.0) (one 1.0) (two 2.0)) + (declare (type (double-float 0.0 0.0) zero) + (type (double-float 1.0 1.0) one) + (type (double-float 2.0 2.0) two)) + (defun dbdsdc (uplo compq n d e u ldu vt ldvt q iq work iwork info) + (declare (type (array fixnum (*)) iwork iq) + (type (array double-float (*)) work q vt u e d) + (type fixnum info ldvt ldu n) + (type (simple-array character (*)) compq uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (compq character compq-%data% compq-%offset%) + (d double-float d-%data% d-%offset%) + (e double-float e-%data% e-%offset%) + (u double-float u-%data% u-%offset%) + (vt double-float vt-%data% vt-%offset%) + (q double-float q-%data% q-%offset%) + (work double-float work-%data% work-%offset%) + (iq fixnum iq-%data% iq-%offset%) + (iwork fixnum iwork-%data% iwork-%offset%)) + (prog ((cs 0.0) (eps 0.0) (orgnrm 0.0) (p 0.0) (r 0.0) (sn 0.0) (difl 0) + (difr 0) (givcol 0) (givnum 0) (givptr 0) (i 0) (ic 0) (icompq 0) + (ierr 0) (ii 0) (is 0) (iu 0) (iuplo 0) (ivt 0) (j 0) (k 0) (kk 0) + (mlvl 0) (nm1 0) (nsize 0) (perm 0) (poles 0) (qstart 0) + (smlsiz 0) (smlszp 0) (sqre 0) (start 0) (wstart 0) (z 0)) + (declare (type (double-float) cs eps orgnrm p r sn) + (type fixnum 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)) + (setf info 0) + (setf iuplo 0) + (if (lsame uplo "U") (setf iuplo 1)) + (if (lsame uplo "L") (setf iuplo 2)) + (cond + ((lsame compq "N") (setf icompq 0)) + ((lsame compq "P") (setf icompq 1)) + ((lsame compq "I") (setf icompq 2)) + (t (setf icompq -1))) + (cond + ((= iuplo 0) (setf info -1)) + ((< icompq 0) (setf info -2)) + ((< n 0) (setf info -3)) + ((or (< ldu 1) (and (= icompq 2) (< ldu n))) (setf info -7)) + ((or (< ldvt 1) (and (= icompq 2) (< ldvt n))) (setf info -9))) + (cond + ((/= info 0) + (xerbla "DBDSDC" (f2cl-lib:int-sub info)) + (go end_label))) + (if (= n 0) (go end_label)) + (setf smlsiz (ilaenv 9 "DBDSDC" " " 0 0 0 0)) + (cond + ((= n 1) + (cond + ((= icompq 1) + (setf + (f2cl-lib:fref q-%data% (1) ((1 *)) q-%offset%) + (f2cl-lib:sign one + (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%))) + (setf + (f2cl-lib:fref q-%data% + ((f2cl-lib:int-add 1 + (f2cl-lib:int-mul smlsiz n))) ((1 *)) q-%offset%) + one)) + ((= icompq 2) + (setf + (f2cl-lib:fref u-%data% (1 1) ((1 ldu) (1 *)) u-%offset%) + (f2cl-lib:sign one (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%))) + (setf + (f2cl-lib:fref vt-%data% (1 1) ((1 ldvt) (1 *)) vt-%offset%) + one))) + (setf (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%) + (abs (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%))) + (go end_label))) + (setf nm1 (f2cl-lib:int-sub n 1)) + (setf wstart 1) + (setf qstart 3) + (cond + ((= icompq 1) + (dcopy n d 1 (f2cl-lib:array-slice q double-float (1) ((1 *))) 1) + (dcopy (f2cl-lib:int-sub n 1) e 1 + (f2cl-lib:array-slice q double-float ((+ n 1)) ((1 *))) 1))) + (cond + ((= iuplo 2) + (setf qstart 5) + (setf wstart (f2cl-lib:int-sub (f2cl-lib:int-mul 2 n) 1)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add n (f2cl-lib:int-sub 1))) nil) + (tagbody + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlartg (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) cs sn r) + (declare (ignore var-0 var-1)) + (setf cs var-2) + (setf sn var-3) + (setf r var-4)) + (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) r) + (setf + (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) + (* sn (f2cl-lib:fref + d-%data% ((f2cl-lib:int-add i 1)) ((1 *)) d-%offset%))) + (setf + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-add i 1)) ((1 *)) d-%offset%) + (* cs (f2cl-lib:fref + d-%data% ((f2cl-lib:int-add i 1)) ((1 *)) d-%offset%))) + (cond + ((= icompq 1) + (setf + (f2cl-lib:fref q-%data% + ((f2cl-lib:int-add i (f2cl-lib:int-mul 2 n))) + ((1 *)) q-%offset%) + cs) + (setf + (f2cl-lib:fref q-%data% + ((f2cl-lib:int-add i (f2cl-lib:int-mul 3 n))) + ((1 *)) q-%offset%) + sn)) + ((= icompq 2) + (setf (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) cs) + (setf + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add nm1 i)) ((1 *)) work-%offset%) + (- sn)))))))) + (cond + ((= icompq 0) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 + var-10 var-11 var-12 var-13 var-14 var-15) + (dlasdq "U" 0 n 0 0 0 d e vt ldvt u ldu u ldu + (f2cl-lib:array-slice work double-float (wstart) ((1 *))) info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14)) + (setf info var-15)) + (go label40))) + (cond + ((<= n smlsiz) + (cond + ((= icompq 2) + (dlaset "A" n n zero one u ldu) + (dlaset "A" n n zero one vt ldvt) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13 var-14 var-15) + (dlasdq "U" 0 n n n 0 d e vt ldvt u ldu u ldu + (f2cl-lib:array-slice work double-float (wstart) ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12 var-13 var-14)) + (setf info var-15))) + ((= icompq 1) + (setf iu 1) + (setf ivt (f2cl-lib:int-add iu n)) + (dlaset "A" n n zero one + (f2cl-lib:array-slice q double-float + ((+ iu + (f2cl-lib:int-mul + (f2cl-lib:int-add qstart (f2cl-lib:int-sub 1)) n))) + ((1 *))) + n) + (dlaset "A" n n zero one + (f2cl-lib:array-slice q double-float + ((+ ivt + (f2cl-lib:int-mul + (f2cl-lib:int-add qstart (f2cl-lib:int-sub 1)) n))) + ((1 *))) + n) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13 var-14 var-15) + (dlasdq "U" 0 n n n 0 d e + (f2cl-lib:array-slice q double-float + ((+ ivt + (f2cl-lib:int-mul + (f2cl-lib:int-add qstart (f2cl-lib:int-sub 1)) + n))) + ((1 *))) + n + (f2cl-lib:array-slice q double-float + ((+ iu + (f2cl-lib:int-mul + (f2cl-lib:int-add qstart (f2cl-lib:int-sub 1)) + n))) + ((1 *))) + n + (f2cl-lib:array-slice q double-float + ((+ iu + (f2cl-lib:int-mul + (f2cl-lib:int-add qstart (f2cl-lib:int-sub 1)) + n))) + ((1 *))) + n + (f2cl-lib:array-slice work double-float (wstart) ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12 var-13 var-14)) + (setf info var-15)))) + (go label40))) + (cond + ((= icompq 2) + (dlaset "A" n n zero one u ldu) + (dlaset "A" n n zero one vt ldvt))) + (setf orgnrm (dlanst "M" n d e)) + (if (= orgnrm zero) (go end_label)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dlascl "G" 0 0 orgnrm one n 1 d n ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf ierr var-9)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dlascl "G" 0 0 orgnrm one nm1 1 e nm1 ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf ierr var-9)) + (setf eps (dlamch "Epsilon")) + (setf mlvl + (f2cl-lib:int-add + (f2cl-lib:int + (/ + (f2cl-lib:flog + (/ (coerce (realpart n) 'double-float) + (coerce (realpart (f2cl-lib:int-add smlsiz 1)) 'double-float))) + (f2cl-lib:flog two))) + 1)) + (setf smlszp (f2cl-lib:int-add smlsiz 1)) + (cond + ((= icompq 1) + (setf iu 1) + (setf ivt (f2cl-lib:int-add 1 smlsiz)) + (setf difl (f2cl-lib:int-add ivt smlszp)) + (setf difr (f2cl-lib:int-add difl mlvl)) + (setf z (f2cl-lib:int-add difr (f2cl-lib:int-mul mlvl 2))) + (setf ic (f2cl-lib:int-add z mlvl)) + (setf is (f2cl-lib:int-add ic 1)) + (setf poles (f2cl-lib:int-add is 1)) + (setf givnum (f2cl-lib:int-add poles (f2cl-lib:int-mul 2 mlvl))) + (setf k 1) + (setf givptr 2) + (setf perm 3) + (setf givcol (f2cl-lib:int-add perm mlvl)))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (cond + ((< (abs (f2cl-lib:fref d (i) ((1 *)))) eps) + (setf + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + (f2cl-lib:sign eps + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%))))))) + (setf start 1) + (setf sqre 0) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i nm1) nil) + (tagbody + (cond + ((or (< (abs (f2cl-lib:fref e (i) ((1 *)))) eps) (= i nm1)) + (cond + ((< i nm1) + (setf nsize (f2cl-lib:int-add (f2cl-lib:int-sub i start) 1))) + ((>= (abs (f2cl-lib:fref e (i) ((1 *)))) eps) + (setf nsize (f2cl-lib:int-add (f2cl-lib:int-sub n start) 1))) + (t + (setf nsize (f2cl-lib:int-add (f2cl-lib:int-sub i start) 1)) + (cond + ((= icompq 2) + (setf + (f2cl-lib:fref u-%data% (n n) ((1 ldu) (1 *)) u-%offset%) + (f2cl-lib:sign one + (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%))) + (setf + (f2cl-lib:fref vt-%data% (n n) ((1 ldvt) (1 *)) vt-%offset%) + one)) + ((= icompq 1) + (setf + (f2cl-lib:fref q-%data% + ((f2cl-lib:int-add n + (f2cl-lib:int-mul (f2cl-lib:int-sub qstart 1) n))) + ((1 *)) q-%offset%) + (f2cl-lib:sign one + (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%))) + (setf + (f2cl-lib:fref q-%data% + ((f2cl-lib:int-add n + (f2cl-lib:int-mul + (f2cl-lib:int-sub + (f2cl-lib:int-add smlsiz qstart) 1) n))) + ((1 *)) q-%offset%) + one))) + (setf + (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%) + (abs (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%))))) + (cond + ((= icompq 2) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11) + (dlasd0 nsize sqre + (f2cl-lib:array-slice d double-float (start) ((1 *))) + (f2cl-lib:array-slice e double-float (start) ((1 *))) + (f2cl-lib:array-slice u double-float + (start start) ((1 ldu) (1 *))) + ldu + (f2cl-lib:array-slice vt double-float + (start start) ((1 ldvt) (1 *))) + ldvt + smlsiz + iwork + (f2cl-lib:array-slice work double-float (wstart) ((1 *))) info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10)) + (setf info var-11))) + (t + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13 var-14 var-15 var-16 + var-17 var-18 var-19 var-20 var-21 var-22 var-23) + (dlasda icompq smlsiz nsize sqre + (f2cl-lib:array-slice d double-float (start) ((1 *))) + (f2cl-lib:array-slice e double-float (start) ((1 *))) + (f2cl-lib:array-slice q double-float + ((+ start (f2cl-lib:int-mul (f2cl-lib:int-add iu qstart + (f2cl-lib:int-sub 2)) n))) ((1 *))) + n + (f2cl-lib:array-slice q double-float + ((+ start (f2cl-lib:int-mul (f2cl-lib:int-add ivt qstart + (f2cl-lib:int-sub 2)) n))) ((1 *))) + (f2cl-lib:array-slice iq fixnum + ((+ start (f2cl-lib:int-mul k n))) ((1 *))) + (f2cl-lib:array-slice q double-float + ((+ start (f2cl-lib:int-mul (f2cl-lib:int-add difl qstart + (f2cl-lib:int-sub 2)) n))) ((1 *))) + (f2cl-lib:array-slice q double-float + ((+ start (f2cl-lib:int-mul (f2cl-lib:int-add difr qstart + (f2cl-lib:int-sub 2)) n))) ((1 *))) + (f2cl-lib:array-slice q double-float + ((+ start (f2cl-lib:int-mul (f2cl-lib:int-add z qstart + (f2cl-lib:int-sub 2)) n))) ((1 *))) + (f2cl-lib:array-slice q double-float + ((+ start (f2cl-lib:int-mul (f2cl-lib:int-add poles qstart + (f2cl-lib:int-sub 2)) n))) ((1 *))) + (f2cl-lib:array-slice iq fixnum + ((+ start (f2cl-lib:int-mul givptr n))) ((1 *))) + (f2cl-lib:array-slice iq fixnum + ((+ start (f2cl-lib:int-mul givcol n))) ((1 *))) + n + (f2cl-lib:array-slice iq fixnum + ((+ start (f2cl-lib:int-mul perm n))) ((1 *))) + (f2cl-lib:array-slice q double-float + ((+ start (f2cl-lib:int-mul (f2cl-lib:int-add givnum qstart + (f2cl-lib:int-sub 2)) n))) ((1 *))) + (f2cl-lib:array-slice q double-float + ((+ start (f2cl-lib:int-mul (f2cl-lib:int-add ic qstart + (f2cl-lib:int-sub 2)) n))) ((1 *))) + (f2cl-lib:array-slice q double-float + ((+ start (f2cl-lib:int-mul (f2cl-lib:int-add is qstart + (f2cl-lib:int-sub 2)) n))) ((1 *))) + (f2cl-lib:array-slice work double-float (wstart) ((1 *))) + iwork + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12 + var-13 var-14 var-15 var-16 var-17 var-18 + var-19 var-20 var-21 var-22)) + (setf info var-23)) + (cond + ((/= info 0) (go end_label))))) + (setf start (f2cl-lib:int-add i 1)))))) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dlascl "G" 0 0 one orgnrm n 1 d n ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)) + (setf ierr var-9)) + label40 + (f2cl-lib:fdo (ii 2 (f2cl-lib:int-add ii 1)) + ((> ii n) nil) + (tagbody + (setf i (f2cl-lib:int-sub ii 1)) + (setf kk i) + (setf p (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) + (f2cl-lib:fdo (j ii (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((> (f2cl-lib:fref d (j) ((1 *))) p) + (setf kk j) + (setf p (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%)))))) + (cond + ((/= kk i) + (setf (f2cl-lib:fref d-%data% (kk) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) + (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) p) + (cond + ((= icompq 1) + (setf (f2cl-lib:fref iq-%data% (i) ((1 *)) iq-%offset%) kk)) + ((= icompq 2) + (dswap n + (f2cl-lib:array-slice u double-float (1 i) ((1 ldu) (1 *))) + 1 + (f2cl-lib:array-slice u double-float (1 kk) ((1 ldu) (1 *))) + 1) + (dswap n + (f2cl-lib:array-slice vt double-float (i 1) ((1 ldvt) (1 *))) + ldvt + (f2cl-lib:array-slice vt double-float (kk 1) ((1 ldvt) (1 *))) + ldvt)))) + ((= icompq 1) + (setf (f2cl-lib:fref iq-%data% (i) ((1 *)) iq-%offset%) i))))) + (cond + ((= icompq 1) + (cond + ((= iuplo 1) + (setf (f2cl-lib:fref iq-%data% (n) ((1 *)) iq-%offset%) 1)) + (t + (setf (f2cl-lib:fref iq-%data% (n) ((1 *)) iq-%offset%) 0))))) + (if (and (= iuplo 2) (= icompq 2)) + (dlasr "L" "V" "B" n n + (f2cl-lib:array-slice work double-float (1) ((1 *))) + (f2cl-lib:array-slice work double-float (n) ((1 *))) u ldu)) + end_label + (return + (values nil nil nil nil nil nil nil nil nil nil nil nil nil info)))))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dcabs1 BLAS} +\pagehead{dcabs1}{dcabs1} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +The argument is: +\begin{itemize} +\item z - (complex double-float) +\end{itemize} + +The result is +\begin{itemize} +\item nil +\end{itemize} + +<>= +(defun dcabs1 (z) + (declare (type (complex double-float) z)) + (let ((dcabs1 0.0)) + (declare (type (double-float) dcabs1)) + (setf dcabs1 + (the double-float + (+ + (the double-float (abs + (the double-float (coerce (realpart z) 'double-float)))) + (the double-float (abs (f2cl-lib:dimag z)))))) + (values dcabs1 nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dbdsqr LAPACK} +\pagehead{dbdsqr}{dbdsqr} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0) + (one 1.0) + (negone (- 1.0)) + (hndrth 0.01) + (ten 10.0) + (hndrd 100.0) + (meigth (- 0.125)) + (maxitr 6)) + (declare (type (double-float 0.0 0.0) zero) + (type (double-float 1.0 1.0) one) + (type (double-float) negone) + (type (double-float 0.01 0.01) hndrth) + (type (double-float 10.0 10.0) ten) + (type (double-float 100.0 100.0) hndrd) + (type (double-float) meigth) + (type (fixnum 6 6) maxitr)) + (defun dbdsqr (uplo n ncvt nru ncc d e vt ldvt u ldu c ldc work info) + (declare (type (array double-float (*)) work c u vt e d) + (type fixnum info ldc ldu ldvt ncc nru ncvt n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (d double-float d-%data% d-%offset%) + (e double-float e-%data% e-%offset%) + (vt double-float vt-%data% vt-%offset%) + (u double-float u-%data% u-%offset%) + (c double-float c-%data% c-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((abse 0.0) (abss 0.0) (cosl 0.0) (cosr 0.0) (cs 0.0) (eps 0.0) + (f 0.0) (g 0.0) (h 0.0) (mu 0.0) (oldcs 0.0) (oldsn 0.0) (r 0.0) + (shift 0.0) (sigmn 0.0) (sigmx 0.0) (sinl 0.0) (sinr 0.0) + (sll 0.0) (smax 0.0) (smin 0.0) (sminl 0.0) (sminlo 0.0) + (sminoa 0.0) (sn 0.0) (thresh 0.0) (tol 0.0) (tolmul 0.0) + (unfl 0.0) (i 0) (idir 0) (isub 0) (iter 0) (j 0) (ll 0) (lll 0) + (m 0) (maxit 0) (nm1 0) (nm12 0) (nm13 0) (oldll 0) (oldm 0) + (lower nil) (rotate nil)) + (declare (type (double-float) 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) + (type fixnum i idir isub iter j ll lll m maxit + nm1 nm12 nm13 oldll oldm) + (type (member t nil) lower rotate)) + (setf info 0) + (setf lower (lsame uplo "L")) + (cond + ((and (not (lsame uplo "U")) (not lower)) + (setf info -1)) + ((< n 0) + (setf info -2)) + ((< ncvt 0) + (setf info -3)) + ((< nru 0) + (setf info -4)) + ((< ncc 0) + (setf info -5)) + ((or (and (= ncvt 0) (< ldvt 1)) + (and (> ncvt 0) + (< ldvt + (max (the fixnum 1) + (the fixnum n))))) + (setf info -9)) + ((< ldu (max (the fixnum 1) (the fixnum nru))) + (setf info -11)) + ((or (and (= ncc 0) (< ldc 1)) + (and (> ncc 0) + (< ldc + (max (the fixnum 1) + (the fixnum n))))) + (setf info -13))) + (cond + ((/= info 0) + (xerbla "DBDSQR" (f2cl-lib:int-sub info)) + (go end_label))) + (if (= n 0) (go end_label)) + (if (= n 1) (go label160)) + (setf rotate (or (> ncvt 0) (> nru 0) (> ncc 0))) + (cond + ((not rotate) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlasq1 n d e work info) + (declare (ignore var-0 var-1 var-2 var-3)) + (setf info var-4)) + (go end_label))) + (setf nm1 (f2cl-lib:int-sub n 1)) + (setf nm12 (f2cl-lib:int-add nm1 nm1)) + (setf nm13 (f2cl-lib:int-add nm12 nm1)) + (setf idir 0) + (setf eps (dlamch "Epsilon")) + (setf unfl (dlamch "Safe minimum")) + (cond + (lower + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add n (f2cl-lib:int-sub 1))) nil) + (tagbody + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlartg (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) cs sn r) + (declare (ignore var-0 var-1)) + (setf cs var-2) + (setf sn var-3) + (setf r var-4)) + (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) r) + (setf (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) + (* sn + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + d-%offset%))) + (setf (f2cl-lib:fref d-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + d-%offset%) + (* cs + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + d-%offset%))) + (setf (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) cs) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add nm1 i)) + ((1 *)) + work-%offset%) + sn))) + (if (> nru 0) + (dlasr "R" "V" "F" nru n + (f2cl-lib:array-slice work double-float (1) ((1 *))) + (f2cl-lib:array-slice work double-float (n) ((1 *))) u ldu)) + (if (> ncc 0) + (dlasr "L" "V" "F" n ncc + (f2cl-lib:array-slice work double-float (1) ((1 *))) + (f2cl-lib:array-slice work double-float (n) ((1 *))) c ldc)))) + (setf tolmul (max ten (min hndrd (expt eps meigth)))) + (setf tol (* tolmul eps)) + (setf smax zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf smax + (max smax + (abs + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add n (f2cl-lib:int-sub 1))) nil) + (tagbody + (setf smax + (max smax + (abs + (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%)))))) + (setf sminl zero) + (cond + ((>= tol zero) + (tagbody + (setf sminoa + (abs (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%))) + (if (= sminoa zero) (go label50)) + (setf mu sminoa) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf mu + (* + (abs (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) + (/ mu + (+ mu + (abs + (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + e-%offset%)))))) + (setf sminoa (min sminoa mu)) + (if (= sminoa zero) (go label50)))) + label50 + (setf sminoa + (/ sminoa (f2cl-lib:fsqrt (coerce (realpart n) 'double-float)))) + (setf thresh (max (* tol sminoa) (* maxitr n n unfl))))) + (t + (setf thresh (max (* (abs tol) smax) (* maxitr n n unfl))))) + (setf maxit (f2cl-lib:int-mul maxitr n n)) + (setf iter 0) + (setf oldll -1) + (setf oldm -1) + (setf m n) + label60 + (if (<= m 1) (go label160)) + (if (> iter maxit) (go label200)) + (if + (and (< tol zero) + (<= (abs (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%)) + thresh)) + (setf (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%) zero)) + (setf smax (abs (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%))) + (setf smin smax) + (f2cl-lib:fdo (lll 1 (f2cl-lib:int-add lll 1)) + ((> lll (f2cl-lib:int-add m (f2cl-lib:int-sub 1))) nil) + (tagbody + (setf ll (f2cl-lib:int-sub m lll)) + (setf abss (abs (f2cl-lib:fref d-%data% (ll) ((1 *)) d-%offset%))) + (setf abse (abs (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%))) + (if (and (< tol zero) (<= abss thresh)) + (setf (f2cl-lib:fref d-%data% (ll) ((1 *)) d-%offset%) zero)) + (if (<= abse thresh) (go label80)) + (setf smin (min smin abss)) + (setf smax (max smax abss abse)))) + (setf ll 0) + (go label90) + label80 + (setf (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%) zero) + (cond + ((= ll (f2cl-lib:int-add m (f2cl-lib:int-sub 1))) + (setf m (f2cl-lib:int-sub m 1)) + (go label60))) + label90 + (setf ll (f2cl-lib:int-add ll 1)) + (cond + ((= ll (f2cl-lib:int-add m (f2cl-lib:int-sub 1))) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dlasv2 + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub m 1)) + ((1 *)) + d-%offset%) + (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub m 1)) + ((1 *)) + e-%offset%) + (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%) sigmn sigmx + sinr cosr sinl cosl) + (declare (ignore var-0 var-1 var-2)) + (setf sigmn var-3) + (setf sigmx var-4) + (setf sinr var-5) + (setf cosr var-6) + (setf sinl var-7) + (setf cosl var-8)) + (setf (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub m 1)) + ((1 *)) + d-%offset%) + sigmx) + (setf (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub m 1)) + ((1 *)) + e-%offset%) + zero) + (setf (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%) sigmn) + (if (> ncvt 0) + (drot ncvt + (f2cl-lib:array-slice vt + double-float + ((+ m (f2cl-lib:int-sub 1)) 1) + ((1 ldvt) (1 *))) + ldvt + (f2cl-lib:array-slice vt double-float (m 1) ((1 ldvt) (1 *))) + ldvt cosr sinr)) + (if (> nru 0) + (drot nru + (f2cl-lib:array-slice u + double-float + (1 (f2cl-lib:int-sub m 1)) + ((1 ldu) (1 *))) + 1 (f2cl-lib:array-slice u double-float (1 m) ((1 ldu) (1 *))) 1 + cosl sinl)) + (if (> ncc 0) + (drot ncc + (f2cl-lib:array-slice c + double-float + ((+ m (f2cl-lib:int-sub 1)) 1) + ((1 ldc) (1 *))) + ldc (f2cl-lib:array-slice c double-float (m 1) ((1 ldc) (1 *))) + ldc cosl sinl)) + (setf m (f2cl-lib:int-sub m 2)) + (go label60))) + (cond + ((or (> ll oldm) (< m oldll)) + (cond + ((>= (abs (f2cl-lib:fref d (ll) ((1 *)))) + (abs (f2cl-lib:fref d (m) ((1 *))))) + (setf idir 1)) + (t + (setf idir 2))))) + (cond + ((= idir 1) + (cond + ((or + (<= + (abs + (f2cl-lib:fref e + ((f2cl-lib:int-add m (f2cl-lib:int-sub 1))) + ((1 *)))) + (* (abs tol) (abs (f2cl-lib:fref d (m) ((1 *)))))) + (and (< tol zero) + (<= + (abs + (f2cl-lib:fref e + ((f2cl-lib:int-add m + (f2cl-lib:int-sub 1))) + ((1 *)))) + thresh))) + (setf (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub m 1)) + ((1 *)) + e-%offset%) + zero) + (go label60))) + (cond + ((>= tol zero) + (setf mu (abs (f2cl-lib:fref d-%data% (ll) ((1 *)) d-%offset%))) + (setf sminl mu) + (f2cl-lib:fdo (lll ll (f2cl-lib:int-add lll 1)) + ((> lll (f2cl-lib:int-add m (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + ((<= (abs (f2cl-lib:fref e (lll) ((1 *)))) (* tol mu)) + (setf (f2cl-lib:fref e-%data% (lll) ((1 *)) e-%offset%) + zero) + (go label60))) + (setf sminlo sminl) + (setf mu + (* + (abs + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-add lll 1)) + ((1 *)) + d-%offset%)) + (/ mu + (+ mu + (abs + (f2cl-lib:fref e-%data% + (lll) + ((1 *)) + e-%offset%)))))) + (setf sminl (min sminl mu))))))) + (t + (cond + ((or + (<= (abs (f2cl-lib:fref e (ll) ((1 *)))) + (* (abs tol) (abs (f2cl-lib:fref d (ll) ((1 *)))))) + (and (< tol zero) + (<= (abs (f2cl-lib:fref e (ll) ((1 *)))) thresh))) + (setf (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%) zero) + (go label60))) + (cond + ((>= tol zero) + (setf mu (abs (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%))) + (setf sminl mu) + (f2cl-lib:fdo (lll (f2cl-lib:int-add m (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add lll (f2cl-lib:int-sub 1))) + ((> lll ll) nil) + (tagbody + (cond + ((<= (abs (f2cl-lib:fref e (lll) ((1 *)))) (* tol mu)) + (setf (f2cl-lib:fref e-%data% (lll) ((1 *)) e-%offset%) + zero) + (go label60))) + (setf sminlo sminl) + (setf mu + (* + (abs + (f2cl-lib:fref d-%data% (lll) ((1 *)) d-%offset%)) + (/ mu + (+ mu + (abs + (f2cl-lib:fref e-%data% + (lll) + ((1 *)) + e-%offset%)))))) + (setf sminl (min sminl mu)))))))) + (setf oldll ll) + (setf oldm m) + (cond + ((and (>= tol zero) + (<= (* n tol (f2cl-lib:f2cl/ sminl smax)) + (max eps (* hndrth tol)))) + (setf shift zero)) + (t + (cond + ((= idir 1) + (setf sll (abs (f2cl-lib:fref d-%data% (ll) ((1 *)) d-%offset%))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlas2 + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub m 1)) + ((1 *)) + d-%offset%) + (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub m 1)) + ((1 *)) + e-%offset%) + (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%) shift r) + (declare (ignore var-0 var-1 var-2)) + (setf shift var-3) + (setf r var-4))) + (t + (setf sll (abs (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlas2 (f2cl-lib:fref d-%data% (ll) ((1 *)) d-%offset%) + (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%) + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-add ll 1)) + ((1 *)) + d-%offset%) + shift r) + (declare (ignore var-0 var-1 var-2)) + (setf shift var-3) + (setf r var-4)))) + (cond + ((> sll zero) + (if (< (expt (/ shift sll) 2) eps) (setf shift zero)))))) + (setf iter (f2cl-lib:int-sub (f2cl-lib:int-add iter m) ll)) + (cond + ((= shift zero) + (cond + ((= idir 1) + (setf cs one) + (setf oldcs one) + (f2cl-lib:fdo (i ll (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add m (f2cl-lib:int-sub 1))) + nil) + (tagbody + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlartg + (* (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) cs) + (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) cs sn r) + (declare (ignore var-0 var-1)) + (setf cs var-2) + (setf sn var-3) + (setf r var-4)) + (if (> i ll) + (setf (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + e-%offset%) + (* oldsn r))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlartg (* oldcs r) + (* + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + d-%offset%) + sn) + oldcs oldsn + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) + (declare (ignore var-0 var-1)) + (setf oldcs var-2) + (setf oldsn var-3) + (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + var-4)) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub i ll) + 1)) + ((1 *)) + work-%offset%) + cs) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub i ll) + 1 + nm1)) + ((1 *)) + work-%offset%) + sn) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub i ll) + 1 + nm12)) + ((1 *)) + work-%offset%) + oldcs) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub i ll) + 1 + nm13)) + ((1 *)) + work-%offset%) + oldsn))) + (setf h (* (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%) cs)) + (setf (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%) (* h oldcs)) + (setf (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub m 1)) + ((1 *)) + e-%offset%) + (* h oldsn)) + (if (> ncvt 0) + (dlasr "L" "V" "F" + (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) ncvt + (f2cl-lib:array-slice work double-float (1) ((1 *))) + (f2cl-lib:array-slice work double-float (n) ((1 *))) + (f2cl-lib:array-slice vt + double-float + (ll 1) + ((1 ldvt) (1 *))) + ldvt)) + (if (> nru 0) + (dlasr "R" "V" "F" nru + (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) + (f2cl-lib:array-slice work + double-float + ((+ nm12 1)) + ((1 *))) + (f2cl-lib:array-slice work + double-float + ((+ nm13 1)) + ((1 *))) + (f2cl-lib:array-slice u double-float (1 ll) ((1 ldu) (1 *))) + ldu)) + (if (> ncc 0) + (dlasr "L" "V" "F" + (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) ncc + (f2cl-lib:array-slice work + double-float + ((+ nm12 1)) + ((1 *))) + (f2cl-lib:array-slice work + double-float + ((+ nm13 1)) + ((1 *))) + (f2cl-lib:array-slice c double-float (ll 1) ((1 ldc) (1 *))) + ldc)) + (if + (<= + (abs + (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub m 1)) + ((1 *)) + e-%offset%)) + thresh) + (setf (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub m 1)) + ((1 *)) + e-%offset%) + zero))) + (t + (setf cs one) + (setf oldcs one) + (f2cl-lib:fdo (i m (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add ll 1)) nil) + (tagbody + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlartg + (* (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) cs) + (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + e-%offset%) + cs sn r) + (declare (ignore var-0 var-1)) + (setf cs var-2) + (setf sn var-3) + (setf r var-4)) + (if (< i m) + (setf (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) + (* oldsn r))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlartg (* oldcs r) + (* + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + d-%offset%) + sn) + oldcs oldsn + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) + (declare (ignore var-0 var-1)) + (setf oldcs var-2) + (setf oldsn var-3) + (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + var-4)) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-sub i ll)) + ((1 *)) + work-%offset%) + cs) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub i ll) + nm1)) + ((1 *)) + work-%offset%) + (- sn)) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub i ll) + nm12)) + ((1 *)) + work-%offset%) + oldcs) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub i ll) + nm13)) + ((1 *)) + work-%offset%) + (- oldsn)))) + (setf h (* (f2cl-lib:fref d-%data% (ll) ((1 *)) d-%offset%) cs)) + (setf (f2cl-lib:fref d-%data% (ll) ((1 *)) d-%offset%) + (* h oldcs)) + (setf (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%) + (* h oldsn)) + (if (> ncvt 0) + (dlasr "L" "V" "B" + (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) ncvt + (f2cl-lib:array-slice work + double-float + ((+ nm12 1)) + ((1 *))) + (f2cl-lib:array-slice work + double-float + ((+ nm13 1)) + ((1 *))) + (f2cl-lib:array-slice vt + double-float + (ll 1) + ((1 ldvt) (1 *))) + ldvt)) + (if (> nru 0) + (dlasr "R" "V" "B" nru + (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) + (f2cl-lib:array-slice work double-float (1) ((1 *))) + (f2cl-lib:array-slice work double-float (n) ((1 *))) + (f2cl-lib:array-slice u double-float (1 ll) ((1 ldu) (1 *))) + ldu)) + (if (> ncc 0) + (dlasr "L" "V" "B" + (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) ncc + (f2cl-lib:array-slice work double-float (1) ((1 *))) + (f2cl-lib:array-slice work double-float (n) ((1 *))) + (f2cl-lib:array-slice c double-float (ll 1) ((1 ldc) (1 *))) + ldc)) + (if + (<= (abs (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%)) + thresh) + (setf (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%) zero))))) + (t + (cond + ((= idir 1) + (setf f + (* + (- + (abs (f2cl-lib:fref d-%data% (ll) ((1 *)) d-%offset%)) + shift) + (+ + (f2cl-lib:sign one + (f2cl-lib:fref d-%data% + (ll) + ((1 *)) + d-%offset%)) + (/ shift + (f2cl-lib:fref d-%data% (ll) ((1 *)) d-%offset%))))) + (setf g (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%)) + (f2cl-lib:fdo (i ll (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add m (f2cl-lib:int-sub 1))) + nil) + (tagbody + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlartg f g cosr sinr r) + (declare (ignore var-0 var-1)) + (setf cosr var-2) + (setf sinr var-3) + (setf r var-4)) + (if (> i ll) + (setf (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + e-%offset%) + r)) + (setf f + (+ + (* cosr + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) + (* sinr + (f2cl-lib:fref e-%data% + (i) + ((1 *)) + e-%offset%)))) + (setf (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) + (- + (* cosr + (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%)) + (* sinr + (f2cl-lib:fref d-%data% + (i) + ((1 *)) + d-%offset%)))) + (setf g + (* sinr + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + d-%offset%))) + (setf (f2cl-lib:fref d-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + d-%offset%) + (* cosr + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + d-%offset%))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlartg f g cosl sinl r) + (declare (ignore var-0 var-1)) + (setf cosl var-2) + (setf sinl var-3) + (setf r var-4)) + (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) r) + (setf f + (+ + (* cosl + (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%)) + (* sinl + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + d-%offset%)))) + (setf (f2cl-lib:fref d-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + d-%offset%) + (- + (* cosl + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + d-%offset%)) + (* sinl + (f2cl-lib:fref e-%data% + (i) + ((1 *)) + e-%offset%)))) + (cond + ((< i (f2cl-lib:int-add m (f2cl-lib:int-sub 1))) + (setf g + (* sinl + (f2cl-lib:fref e-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + e-%offset%))) + (setf (f2cl-lib:fref e-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + e-%offset%) + (* cosl + (f2cl-lib:fref e-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + e-%offset%))))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub i ll) + 1)) + ((1 *)) + work-%offset%) + cosr) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub i ll) + 1 + nm1)) + ((1 *)) + work-%offset%) + sinr) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub i ll) + 1 + nm12)) + ((1 *)) + work-%offset%) + cosl) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub i ll) + 1 + nm13)) + ((1 *)) + work-%offset%) + sinl))) + (setf (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub m 1)) + ((1 *)) + e-%offset%) + f) + (if (> ncvt 0) + (dlasr "L" "V" "F" + (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) ncvt + (f2cl-lib:array-slice work double-float (1) ((1 *))) + (f2cl-lib:array-slice work double-float (n) ((1 *))) + (f2cl-lib:array-slice vt + double-float + (ll 1) + ((1 ldvt) (1 *))) + ldvt)) + (if (> nru 0) + (dlasr "R" "V" "F" nru + (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) + (f2cl-lib:array-slice work + double-float + ((+ nm12 1)) + ((1 *))) + (f2cl-lib:array-slice work + double-float + ((+ nm13 1)) + ((1 *))) + (f2cl-lib:array-slice u double-float (1 ll) ((1 ldu) (1 *))) + ldu)) + (if (> ncc 0) + (dlasr "L" "V" "F" + (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) ncc + (f2cl-lib:array-slice work + double-float + ((+ nm12 1)) + ((1 *))) + (f2cl-lib:array-slice work + double-float + ((+ nm13 1)) + ((1 *))) + (f2cl-lib:array-slice c double-float (ll 1) ((1 ldc) (1 *))) + ldc)) + (if + (<= + (abs + (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub m 1)) + ((1 *)) + e-%offset%)) + thresh) + (setf (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub m 1)) + ((1 *)) + e-%offset%) + zero))) + (t + (setf f + (* + (- (abs (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%)) + shift) + (+ + (f2cl-lib:sign one + (f2cl-lib:fref d-%data% + (m) + ((1 *)) + d-%offset%)) + (/ shift + (f2cl-lib:fref d-%data% (m) ((1 *)) d-%offset%))))) + (setf g + (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub m 1)) + ((1 *)) + e-%offset%)) + (f2cl-lib:fdo (i m (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add ll 1)) nil) + (tagbody + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlartg f g cosr sinr r) + (declare (ignore var-0 var-1)) + (setf cosr var-2) + (setf sinr var-3) + (setf r var-4)) + (if (< i m) + (setf (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) r)) + (setf f + (+ + (* cosr + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) + (* sinr + (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + e-%offset%)))) + (setf (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + e-%offset%) + (- + (* cosr + (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + e-%offset%)) + (* sinr + (f2cl-lib:fref d-%data% + (i) + ((1 *)) + d-%offset%)))) + (setf g + (* sinr + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + d-%offset%))) + (setf (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + d-%offset%) + (* cosr + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + d-%offset%))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlartg f g cosl sinl r) + (declare (ignore var-0 var-1)) + (setf cosl var-2) + (setf sinl var-3) + (setf r var-4)) + (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) r) + (setf f + (+ + (* cosl + (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + e-%offset%)) + (* sinl + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + d-%offset%)))) + (setf (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + d-%offset%) + (- + (* cosl + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + d-%offset%)) + (* sinl + (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + e-%offset%)))) + (cond + ((> i (f2cl-lib:int-add ll 1)) + (setf g + (* sinl + (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub i 2)) + ((1 *)) + e-%offset%))) + (setf (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub i 2)) + ((1 *)) + e-%offset%) + (* cosl + (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub i 2)) + ((1 *)) + e-%offset%))))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-sub i ll)) + ((1 *)) + work-%offset%) + cosr) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub i ll) + nm1)) + ((1 *)) + work-%offset%) + (- sinr)) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub i ll) + nm12)) + ((1 *)) + work-%offset%) + cosl) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub i ll) + nm13)) + ((1 *)) + work-%offset%) + (- sinl)))) + (setf (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%) f) + (if + (<= (abs (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%)) + thresh) + (setf (f2cl-lib:fref e-%data% (ll) ((1 *)) e-%offset%) zero)) + (if (> ncvt 0) + (dlasr "L" "V" "B" + (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) ncvt + (f2cl-lib:array-slice work + double-float + ((+ nm12 1)) + ((1 *))) + (f2cl-lib:array-slice work + double-float + ((+ nm13 1)) + ((1 *))) + (f2cl-lib:array-slice vt + double-float + (ll 1) + ((1 ldvt) (1 *))) + ldvt)) + (if (> nru 0) + (dlasr "R" "V" "B" nru + (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) + (f2cl-lib:array-slice work double-float (1) ((1 *))) + (f2cl-lib:array-slice work double-float (n) ((1 *))) + (f2cl-lib:array-slice u double-float (1 ll) ((1 ldu) (1 *))) + ldu)) + (if (> ncc 0) + (dlasr "L" "V" "B" + (f2cl-lib:int-add (f2cl-lib:int-sub m ll) 1) ncc + (f2cl-lib:array-slice work double-float (1) ((1 *))) + (f2cl-lib:array-slice work double-float (n) ((1 *))) + (f2cl-lib:array-slice c double-float (ll 1) ((1 ldc) (1 *))) + ldc)))))) + (go label60) + label160 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (cond + ((< (f2cl-lib:fref d (i) ((1 *))) zero) + (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + (- (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%))) + (if (> ncvt 0) + (dscal ncvt negone + (f2cl-lib:array-slice vt + double-float + (i 1) + ((1 ldvt) (1 *))) + ldvt)))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add n (f2cl-lib:int-sub 1))) nil) + (tagbody + (setf isub 1) + (setf smin (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%)) + (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1)) + ((> j (f2cl-lib:int-add n 1 (f2cl-lib:int-sub i))) + nil) + (tagbody + (cond + ((<= (f2cl-lib:fref d (j) ((1 *))) smin) + (setf isub j) + (setf smin + (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%)))))) + (cond + ((/= isub (f2cl-lib:int-add n 1 (f2cl-lib:int-sub i))) + (setf (f2cl-lib:fref d-%data% (isub) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-add n 1) + i)) + ((1 *)) + d-%offset%)) + (setf (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-add n 1) + i)) + ((1 *)) + d-%offset%) + smin) + (if (> ncvt 0) + (dswap ncvt + (f2cl-lib:array-slice vt + double-float + (isub 1) + ((1 ldvt) (1 *))) + ldvt + (f2cl-lib:array-slice vt + double-float + ((+ n 1 (f2cl-lib:int-sub i)) 1) + ((1 ldvt) (1 *))) + ldvt)) + (if (> nru 0) + (dswap nru + (f2cl-lib:array-slice u + double-float + (1 isub) + ((1 ldu) (1 *))) + 1 + (f2cl-lib:array-slice u + double-float + (1 + (f2cl-lib:int-sub + (f2cl-lib:int-add n 1) + i)) + ((1 ldu) (1 *))) + 1)) + (if (> ncc 0) + (dswap ncc + (f2cl-lib:array-slice c + double-float + (isub 1) + ((1 ldc) (1 *))) + ldc + (f2cl-lib:array-slice c + double-float + ((+ n 1 (f2cl-lib:int-sub i)) 1) + ((1 ldc) (1 *))) + ldc)))))) + (go end_label) + label200 + (setf info 0) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add n (f2cl-lib:int-sub 1))) nil) + (tagbody + (if (/= (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) zero) + (setf info (f2cl-lib:int-add info 1))))) + end_label + (return + (values nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dbdsqr + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum fixnum + fixnum fixnum + (array double-float (*)) (array double-float (*)) + (array double-float (*)) fixnum + (array double-float (*)) fixnum + (array double-float (*)) fixnum + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil + nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::dswap fortran-to-lisp::dscal + fortran-to-lisp::dlas2 fortran-to-lisp::drot + fortran-to-lisp::dlasv2 fortran-to-lisp::dlasr + fortran-to-lisp::dlartg fortran-to-lisp::dlamch + fortran-to-lisp::dlasq1 fortran-to-lisp::xerbla + fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dcopy BLAS} +\pagehead{dcopy}{dcopy} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun dcopy (n dx incx dy incy) + (declare (type (array double-float (*)) dy dx) + (type fixnum incy incx n)) + (f2cl-lib:with-multi-array-data + ((dx double-float dx-%data% dx-%offset%) + (dy double-float dy-%data% dy-%offset%)) + (prog ((i 0) (ix 0) (iy 0) (m 0) (mp1 0)) + (declare (type fixnum mp1 m iy ix i)) + (if (<= n 0) (go end_label)) + (if (and (= incx 1) (= incy 1)) (go label20)) + (setf ix 1) + (setf iy 1) + (if (< incx 0) + (setf ix + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) + 1))) + (if (< incy 0) + (setf iy + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) + 1))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%) + (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%)) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (go end_label) + label20 + (setf m (mod n 7)) + (if (= m 0) (go label40)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%) + (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)))) + (if (< n 7) (go end_label)) + label40 + (setf mp1 (f2cl-lib:int-add m 1)) + (f2cl-lib:fdo (i mp1 (f2cl-lib:int-add i 7)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%) + (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)) + (setf (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + dy-%offset%) + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + dx-%offset%)) + (setf (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 2)) + ((1 *)) + dy-%offset%) + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 2)) + ((1 *)) + dx-%offset%)) + (setf (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 3)) + ((1 *)) + dy-%offset%) + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 3)) + ((1 *)) + dx-%offset%)) + (setf (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 4)) + ((1 *)) + dy-%offset%) + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 4)) + ((1 *)) + dx-%offset%)) + (setf (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 5)) + ((1 *)) + dy-%offset%) + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 5)) + ((1 *)) + dx-%offset%)) + (setf (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 6)) + ((1 *)) + dy-%offset%) + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 6)) + ((1 *)) + dx-%offset%)))) + end_label + (return (values nil nil nil nil nil))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dcopy fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum (array double-float (*)) + fixnum (array double-float (*)) + fixnum) + :return-values '(nil nil nil nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ddisna LAPACK} +\pagehead{ddisna}{ddisna} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun ddisna (job m n d sep info) + (declare (type (array double-float (*)) sep d) + (type fixnum info n m) + (type (simple-array character (*)) job)) + (f2cl-lib:with-multi-array-data + ((job character job-%data% job-%offset%) + (d double-float d-%data% d-%offset%) + (sep double-float sep-%data% sep-%offset%)) + (prog ((anorm 0.0) (eps 0.0) (newgap 0.0) (oldgap 0.0) (safmin 0.0) + (thresh 0.0) (i 0) (k 0) (decr nil) (eigen nil) (incr nil) + (left nil) (right nil) (sing nil)) + (declare (type (double-float) anorm eps newgap oldgap safmin thresh) + (type fixnum i k) + (type (member t nil) decr eigen incr left right sing)) + (setf info 0) + (setf eigen (lsame job "E")) + (setf left (lsame job "L")) + (setf right (lsame job "R")) + (setf sing (or left right)) + (cond + (eigen + (setf k m)) + (sing + (setf k (min (the fixnum m) (the fixnum n))))) + (cond + ((and (not eigen) (not sing)) + (setf info -1)) + ((< m 0) + (setf info -2)) + ((< k 0) + (setf info -3)) + (t + (setf incr t) + (setf decr t) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) nil) + (tagbody + (if incr + (setf incr + (and incr + (<= + (f2cl-lib:fref d-%data% + (i) + ((1 *)) + d-%offset%) + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + d-%offset%))))) + (if decr + (setf decr + (and decr + (>= + (f2cl-lib:fref d-%data% + (i) + ((1 *)) + d-%offset%) + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + d-%offset%))))))) + (cond + ((and sing (> k 0)) + (if incr + (setf incr + (and incr + (<= zero + (f2cl-lib:fref d-%data% + (1) + ((1 *)) + d-%offset%))))) + (if decr + (setf decr + (and decr + (>= + (f2cl-lib:fref d-%data% (k) ((1 *)) d-%offset%) + zero)))))) + (if (not (or incr decr)) (setf info -4)))) + (cond + ((/= info 0) + (xerbla "DDISNA" (f2cl-lib:int-sub info)) + (go end_label))) + (if (= k 0) (go end_label)) + (cond + ((= k 1) + (setf (f2cl-lib:fref sep-%data% (1) ((1 *)) sep-%offset%) + (dlamch "O"))) + (t + (setf oldgap + (abs + (- (f2cl-lib:fref d-%data% (2) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%)))) + (setf (f2cl-lib:fref sep-%data% (1) ((1 *)) sep-%offset%) oldgap) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) nil) + (tagbody + (setf newgap + (abs + (- + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + d-%offset%) + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)))) + (setf (f2cl-lib:fref sep-%data% (i) ((1 *)) sep-%offset%) + (min oldgap newgap)) + (setf oldgap newgap))) + (setf (f2cl-lib:fref sep-%data% (k) ((1 *)) sep-%offset%) oldgap))) + (cond + (sing + (cond + ((or (and left (> m n)) (and right (< m n))) + (if incr + (setf (f2cl-lib:fref sep-%data% (1) ((1 *)) sep-%offset%) + (min + (f2cl-lib:fref sep-%data% (1) ((1 *)) sep-%offset%) + (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%)))) + (if decr + (setf (f2cl-lib:fref sep-%data% (k) ((1 *)) sep-%offset%) + (min + (f2cl-lib:fref sep-%data% (k) ((1 *)) sep-%offset%) + (f2cl-lib:fref d-%data% + (k) + ((1 *)) + d-%offset%)))))))) + (setf eps (dlamch "E")) + (setf safmin (dlamch "S")) + (setf anorm + (max (abs (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%)) + (abs (f2cl-lib:fref d-%data% (k) ((1 *)) d-%offset%)))) + (cond + ((= anorm zero) + (setf thresh eps)) + (t + (setf thresh (max (* eps anorm) safmin)))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i k) nil) + (tagbody + (setf (f2cl-lib:fref sep-%data% (i) ((1 *)) sep-%offset%) + (max (f2cl-lib:fref sep-%data% (i) ((1 *)) sep-%offset%) + thresh)))) + end_label + (return (values nil nil nil nil nil info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::ddisna + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum fixnum + (array double-float (*)) (array double-float (*)) + fixnum) + :return-values '(nil nil nil nil nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlamch fortran-to-lisp::xerbla + fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ddot BLAS} +\pagehead{ddot}{ddot} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun ddot (n dx incx dy incy) + (declare (type (array double-float (*)) dy dx) + (type fixnum incy incx n)) + (f2cl-lib:with-multi-array-data + ((dx double-float dx-%data% dx-%offset%) + (dy double-float dy-%data% dy-%offset%)) + (prog ((i 0) (ix 0) (iy 0) (m 0) (mp1 0) (dtemp 0.0) (ddot 0.0)) + (declare (type (double-float) ddot dtemp) + (type fixnum mp1 m iy ix i)) + (setf ddot 0.0) + (setf dtemp 0.0) + (if (<= n 0) (go end_label)) + (if (and (= incx 1) (= incy 1)) (go label20)) + (setf ix 1) + (setf iy 1) + (if (< incx 0) + (setf ix + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) + 1))) + (if (< incy 0) + (setf iy + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) + 1))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf dtemp + (+ dtemp + (* (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%) + (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (setf ddot dtemp) + (go end_label) + label20 + (setf m (mod n 5)) + (if (= m 0) (go label40)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf dtemp + (+ dtemp + (* (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) + (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%)))))) + (if (< n 5) (go label60)) + label40 + (setf mp1 (f2cl-lib:int-add m 1)) + (f2cl-lib:fdo (i mp1 (f2cl-lib:int-add i 5)) + ((> i n) nil) + (tagbody + (setf dtemp + (+ dtemp + (* (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) + (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%)) + (* + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + dx-%offset%) + (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + dy-%offset%)) + (* + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 2)) + ((1 *)) + dx-%offset%) + (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 2)) + ((1 *)) + dy-%offset%)) + (* + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 3)) + ((1 *)) + dx-%offset%) + (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 3)) + ((1 *)) + dy-%offset%)) + (* + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 4)) + ((1 *)) + dx-%offset%) + (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 4)) + ((1 *)) + dy-%offset%)))))) + label60 + (setf ddot dtemp) + end_label + (return (values ddot nil nil nil nil nil))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::ddot fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum (array double-float (*)) + fixnum (array double-float (*)) + fixnum) + :return-values '(nil nil nil nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgbmv BLAS} +\pagehead{dgbmv}{dgbmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(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 dgbmv (trans m n kl ku alpha a lda x incx beta y incy) + (declare (type (array double-float (*)) y x a) + (type (double-float) beta alpha) + (type fixnum incy incx lda ku kl n m) + (type (simple-array character (*)) trans)) + (f2cl-lib:with-multi-array-data + ((trans character trans-%data% trans-%offset%) + (a double-float a-%data% a-%offset%) + (x double-float x-%data% x-%offset%) + (y double-float y-%data% y-%offset%)) + (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (k 0) (kup1 0) + (kx 0) (ky 0) (lenx 0) (leny 0) (temp 0.0)) + (declare (type fixnum i info ix iy j jx jy k kup1 kx ky + lenx leny) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 1)) + ((< m 0) + (setf info 2)) + ((< n 0) + (setf info 3)) + ((< kl 0) + (setf info 4)) + ((< ku 0) + (setf info 5)) + ((< lda (f2cl-lib:int-add kl ku 1)) + (setf info 8)) + ((= incx 0) + (setf info 10)) + ((= incy 0) + (setf info 13))) + (cond + ((/= info 0) + (xerbla "DGBMV " info) + (go end_label))) + (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one))) + (go end_label)) + (cond + ((lsame trans "N") + (setf lenx n) + (setf leny m)) + (t + (setf lenx m) + (setf leny n))) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub lenx 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub leny 1) + incy))))) + (cond + ((/= beta one) + (cond + ((= incy 1) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + zero)))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%)))))))) + (t + (setf iy ky) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + zero) + (setf iy (f2cl-lib:int-add iy incy))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%))) + (setf iy (f2cl-lib:int-add iy incy)))))))))) + (if (= alpha zero) (go end_label)) + (setf kup1 (f2cl-lib:int-add ku 1)) + (cond + ((lsame trans "N") + (setf jx kx) + (cond + ((= incy 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf k (f2cl-lib:int-sub kup1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + ku)))) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum m) + (the fixnum + (f2cl-lib:int-add j kl)))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add k i) j) + ((1 lda) (1 *)) + a-%offset%)))))))) + (setf jx (f2cl-lib:int-add jx incx))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf iy ky) + (setf k (f2cl-lib:int-sub kup1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + ku)))) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum m) + (the fixnum + (f2cl-lib:int-add j kl)))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add k i) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf iy (f2cl-lib:int-add iy incy)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (if (> j ku) (setf ky (f2cl-lib:int-add ky incy)))))))) + (t + (setf jy ky) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp zero) + (setf k (f2cl-lib:int-sub kup1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + ku)))) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum m) + (the fixnum + (f2cl-lib:int-add j kl)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add k i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp))) + (setf jy (f2cl-lib:int-add jy incy))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp zero) + (setf ix kx) + (setf k (f2cl-lib:int-sub kup1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + ku)))) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum m) + (the fixnum + (f2cl-lib:int-add j kl)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add k i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp))) + (setf jy (f2cl-lib:int-add jy incy)) + (if (> j ku) (setf kx (f2cl-lib:int-add kx incx))))))))) + end_label + (return + (values nil nil nil nil nil nil nil nil nil nil nil nil nil)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgbmv fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum fixnum + fixnum fixnum + (double-float) (array double-float (*)) + fixnum (array double-float (*)) + fixnum (double-float) + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil + nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgebak LAPACK} +\pagehead{dgebak}{dgebak} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0)) + (declare (type (double-float 1.0 1.0) one)) + (defun dgebak (job side n ilo ihi scale m v ldv info) + (declare (type (array double-float (*)) v scale) + (type fixnum info ldv m ihi ilo n) + (type (simple-array character (*)) side job)) + (f2cl-lib:with-multi-array-data + ((job character job-%data% job-%offset%) + (side character side-%data% side-%offset%) + (scale double-float scale-%data% scale-%offset%) + (v double-float v-%data% v-%offset%)) + (prog ((s 0.0) (i 0) (ii 0) (k 0) (leftv nil) (rightv nil)) + (declare (type (double-float) s) + (type fixnum i ii k) + (type (member t nil) leftv rightv)) + (setf rightv (lsame side "R")) + (setf leftv (lsame side "L")) + (setf info 0) + (cond + ((and (not (lsame job "N")) + (not (lsame job "P")) + (not (lsame job "S")) + (not (lsame job "B"))) + (setf info -1)) + ((and (not rightv) (not leftv)) + (setf info -2)) + ((< n 0) + (setf info -3)) + ((or (< ilo 1) + (> ilo + (max (the fixnum 1) (the fixnum n)))) + (setf info -4)) + ((or + (< ihi (min (the fixnum ilo) (the fixnum n))) + (> ihi n)) + (setf info -5)) + ((< m 0) + (setf info -7)) + ((< ldv (max (the fixnum 1) (the fixnum n))) + (setf info -9))) + (cond + ((/= info 0) + (xerbla "DGEBAK" (f2cl-lib:int-sub info)) + (go end_label))) + (if (= n 0) (go end_label)) + (if (= m 0) (go end_label)) + (if (lsame job "N") (go end_label)) + (if (= ilo ihi) (go label30)) + (cond + ((or (lsame job "S") (lsame job "B")) + (cond + (rightv + (f2cl-lib:fdo (i ilo (f2cl-lib:int-add i 1)) + ((> i ihi) nil) + (tagbody + (setf s + (f2cl-lib:fref scale-%data% + (i) + ((1 *)) + scale-%offset%)) + (dscal m s + (f2cl-lib:array-slice v double-float (i 1) ((1 ldv) (1 *))) + ldv))))) + (cond + (leftv + (f2cl-lib:fdo (i ilo (f2cl-lib:int-add i 1)) + ((> i ihi) nil) + (tagbody + (setf s + (/ one + (f2cl-lib:fref scale-%data% + (i) + ((1 *)) + scale-%offset%))) + (dscal m s + (f2cl-lib:array-slice v double-float (i 1) ((1 ldv) (1 *))) + ldv))))))) + label30 + (cond + ((or (lsame job "P") (lsame job "B")) + (cond + (rightv + (f2cl-lib:fdo (ii 1 (f2cl-lib:int-add ii 1)) + ((> ii n) nil) + (tagbody + (setf i ii) + (if (and (>= i ilo) (<= i ihi)) (go label40)) + (if (< i ilo) (setf i (f2cl-lib:int-sub ilo ii))) + (setf k + (f2cl-lib:int + (f2cl-lib:fref scale-%data% + (i) + ((1 *)) + scale-%offset%))) + (if (= k i) (go label40)) + (dswap m + (f2cl-lib:array-slice v double-float (i 1) ((1 ldv) (1 *))) + ldv + (f2cl-lib:array-slice v double-float (k 1) ((1 ldv) (1 *))) + ldv) + label40)))) + (cond + (leftv + (f2cl-lib:fdo (ii 1 (f2cl-lib:int-add ii 1)) + ((> ii n) nil) + (tagbody + (setf i ii) + (if (and (>= i ilo) (<= i ihi)) (go label50)) + (if (< i ilo) (setf i (f2cl-lib:int-sub ilo ii))) + (setf k + (f2cl-lib:int + (f2cl-lib:fref scale-%data% + (i) + ((1 *)) + scale-%offset%))) + (if (= k i) (go label50)) + (dswap m + (f2cl-lib:array-slice v double-float (i 1) ((1 ldv) (1 *))) + ldv + (f2cl-lib:array-slice v double-float (k 1) ((1 ldv) (1 *))) + ldv) + label50)))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgebak + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + (simple-array character (1)) + fixnum fixnum + fixnum (array double-float (*)) + fixnum (array double-float (*)) + fixnum + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dswap fortran-to-lisp::dscal + fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgebal LAPACK} +\pagehead{dgebal}{dgebal} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0) (one 1.0) (sclfac 8.0) (factor 0.95)) + (declare (type (double-float 0.0 0.0) zero) + (type (double-float 1.0 1.0) one) + (type (double-float 8.0 8.0) sclfac) + (type (double-float 0.95 0.95) factor)) + (defun dgebal (job n a lda ilo ihi scale info) + (declare (type (array double-float (*)) scale a) + (type fixnum info ihi ilo lda n) + (type (simple-array character (*)) job)) + (f2cl-lib:with-multi-array-data + ((job character job-%data% job-%offset%) + (a double-float a-%data% a-%offset%) + (scale double-float scale-%data% scale-%offset%)) + (prog ((c 0.0) (ca 0.0) (f 0.0) (g 0.0) (r 0.0) (ra 0.0) (s 0.0) + (sfmax1 0.0) (sfmax2 0.0) (sfmin1 0.0) (sfmin2 0.0) (i 0) (ica 0) + (iexc 0) (ira 0) (j 0) (k 0) (l 0) (m 0) (noconv nil)) + (declare (type (double-float) c ca f g r ra s sfmax1 sfmax2 sfmin1 + sfmin2) + (type fixnum i ica iexc ira j k l m) + (type (member t nil) noconv)) + (setf info 0) + (cond + ((and (not (lsame job "N")) + (not (lsame job "P")) + (not (lsame job "S")) + (not (lsame job "B"))) + (setf info -1)) + ((< n 0) + (setf info -2)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info -4))) + (cond + ((/= info 0) + (xerbla "DGEBAL" (f2cl-lib:int-sub info)) + (go end_label))) + (setf k 1) + (setf l n) + (if (= n 0) (go label210)) + (cond + ((lsame job "N") + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref scale-%data% (i) ((1 *)) scale-%offset%) + one))) + (go label210))) + (if (lsame job "S") (go label120)) + (go label50) + label20 + (setf (f2cl-lib:fref scale-%data% (m) ((1 *)) scale-%offset%) + (coerce (the fixnum j) 'double-float)) + (if (= j m) (go label30)) + (dswap l (f2cl-lib:array-slice a double-float (1 j) ((1 lda) (1 *))) 1 + (f2cl-lib:array-slice a double-float (1 m) ((1 lda) (1 *))) 1) + (dswap (f2cl-lib:int-add (f2cl-lib:int-sub n k) 1) + (f2cl-lib:array-slice a double-float (j k) ((1 lda) (1 *))) lda + (f2cl-lib:array-slice a double-float (m k) ((1 lda) (1 *))) lda) + label30 + (f2cl-lib:computed-goto (label40 label80) iexc) + label40 + (if (= l 1) (go label210)) + (setf l (f2cl-lib:int-sub l 1)) + label50 + (f2cl-lib:fdo (j l (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i l) nil) + (tagbody + (if (= i j) (go label60)) + (if + (/= (f2cl-lib:fref a-%data% (j i) ((1 lda) (1 *)) a-%offset%) + zero) + (go label70)) + label60)) + (setf m l) + (setf iexc 1) + (go label20) + label70)) + (go label90) + label80 + (setf k (f2cl-lib:int-add k 1)) + label90 + (f2cl-lib:fdo (j k (f2cl-lib:int-add j 1)) + ((> j l) nil) + (tagbody + (f2cl-lib:fdo (i k (f2cl-lib:int-add i 1)) + ((> i l) nil) + (tagbody + (if (= i j) (go label100)) + (if + (/= (f2cl-lib:fref a-%data% (i j) ((1 lda) (1 *)) a-%offset%) + zero) + (go label110)) + label100)) + (setf m k) + (setf iexc 2) + (go label20) + label110)) + label120 + (f2cl-lib:fdo (i k (f2cl-lib:int-add i 1)) + ((> i l) nil) + (tagbody + (setf (f2cl-lib:fref scale-%data% (i) ((1 *)) scale-%offset%) one))) + (if (lsame job "P") (go label210)) + (setf sfmin1 (/ (dlamch "S") (dlamch "P"))) + (setf sfmax1 (/ one sfmin1)) + (setf sfmin2 (* sfmin1 sclfac)) + (setf sfmax2 (/ one sfmin2)) + label140 + (setf noconv nil) + (f2cl-lib:fdo (i k (f2cl-lib:int-add i 1)) + ((> i l) nil) + (tagbody + (setf c zero) + (setf r zero) + (f2cl-lib:fdo (j k (f2cl-lib:int-add j 1)) + ((> j l) nil) + (tagbody + (if (= j i) (go label150)) + (setf c + (+ c + (abs + (f2cl-lib:fref a-%data% + (j i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf r + (+ r + (abs + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + label150)) + (setf ica + (idamax l + (f2cl-lib:array-slice a + double-float + (1 i) + ((1 lda) (1 *))) + 1)) + (setf ca + (abs + (f2cl-lib:fref a-%data% + (ica i) + ((1 lda) (1 *)) + a-%offset%))) + (setf ira + (idamax (f2cl-lib:int-add (f2cl-lib:int-sub n k) 1) + (f2cl-lib:array-slice a + double-float + (i k) + ((1 lda) (1 *))) + lda)) + (setf ra + (abs + (f2cl-lib:fref a-%data% + (i + (f2cl-lib:int-sub (f2cl-lib:int-add ira k) + 1)) + ((1 lda) (1 *)) + a-%offset%))) + (if (or (= c zero) (= r zero)) (go label200)) + (setf g (/ r sclfac)) + (setf f one) + (setf s (+ c r)) + label160 + (if (or (>= c g) (>= (max f c ca) sfmax2) (<= (min r g ra) sfmin2)) + (go label170)) + (setf f (* f sclfac)) + (setf c (* c sclfac)) + (setf ca (* ca sclfac)) + (setf r (/ r sclfac)) + (setf g (/ g sclfac)) + (setf ra (/ ra sclfac)) + (go label160) + label170 + (setf g (/ c sclfac)) + label180 + (if (or (< g r) (>= (max r ra) sfmax2) (<= (min f c g ca) sfmin2)) + (go label190)) + (setf f (/ f sclfac)) + (setf c (/ c sclfac)) + (setf g (/ g sclfac)) + (setf ca (/ ca sclfac)) + (setf r (* r sclfac)) + (setf ra (* ra sclfac)) + (go label180) + label190 + (if (>= (+ c r) (* factor s)) (go label200)) + (cond + ((and (< f one) (< (f2cl-lib:fref scale (i) ((1 *))) one)) + (if + (<= + (* f (f2cl-lib:fref scale-%data% (i) ((1 *)) scale-%offset%)) + sfmin1) + (go label200)))) + (cond + ((and (> f one) (> (f2cl-lib:fref scale (i) ((1 *))) one)) + (if + (>= (f2cl-lib:fref scale-%data% (i) ((1 *)) scale-%offset%) + (/ sfmax1 f)) + (go label200)))) + (setf g (/ one f)) + (setf (f2cl-lib:fref scale-%data% (i) ((1 *)) scale-%offset%) + (* (f2cl-lib:fref scale-%data% (i) ((1 *)) scale-%offset%) + f)) + (setf noconv t) + (dscal (f2cl-lib:int-add (f2cl-lib:int-sub n k) 1) g + (f2cl-lib:array-slice a double-float (i k) ((1 lda) (1 *))) lda) + (dscal l f + (f2cl-lib:array-slice a double-float (1 i) ((1 lda) (1 *))) 1) + label200)) + (if noconv (go label140)) + label210 + (setf ilo k) + (setf ihi l) + end_label + (return (values nil nil nil nil ilo ihi nil info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgebal + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum (array double-float (*)) + fixnum fixnum + fixnum (array double-float (*)) + fixnum) + :return-values '(nil nil nil nil fortran-to-lisp::ilo + fortran-to-lisp::ihi nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::dscal fortran-to-lisp::idamax + fortran-to-lisp::dlamch fortran-to-lisp::dswap + fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgebd2 LAPACK} +\pagehead{dgebd2}{dgebd2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0) (one 1.0)) + (declare (type (double-float 0.0 0.0) zero) + (type (double-float 1.0 1.0) one)) + (defun dgebd2 (m n a lda d e tauq taup work info) + (declare (type (array double-float (*)) work taup tauq e d a) + (type fixnum info lda n m)) + (f2cl-lib:with-multi-array-data + ((a double-float a-%data% a-%offset%) + (d double-float d-%data% d-%offset%) + (e double-float e-%data% e-%offset%) + (tauq double-float tauq-%data% tauq-%offset%) + (taup double-float taup-%data% taup-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((i 0)) + (declare (type fixnum i)) + (setf info 0) + (cond + ((< m 0) + (setf info -1)) + ((< n 0) + (setf info -2)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info -4))) + (cond + ((< info 0) + (xerbla "DGEBD2" (f2cl-lib:int-sub info)) + (go end_label))) + (cond + ((>= m n) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlarfg (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) + (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) + (f2cl-lib:array-slice a + double-float + ((min (f2cl-lib:int-add i 1) m) i) + ((1 lda) (1 *))) + 1 (f2cl-lib:fref tauq-%data% (i) ((1 *)) tauq-%offset%)) + (declare (ignore var-0 var-2 var-3)) + (setf (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%) + var-1) + (setf (f2cl-lib:fref tauq-%data% (i) ((1 *)) tauq-%offset%) + var-4)) + (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) + one) + (dlarf "Left" (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) + (f2cl-lib:int-sub n i) + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) 1 + (f2cl-lib:fref tauq-%data% (i) ((1 *)) tauq-%offset%) + (f2cl-lib:array-slice a + double-float + (i (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda work) + (setf (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) + (cond + ((< i n) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlarfg (f2cl-lib:int-sub n i) + (f2cl-lib:fref a-%data% + (i (f2cl-lib:int-add i 1)) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:array-slice a + double-float + (i + (min + (the fixnum + (f2cl-lib:int-add i 2)) + (the fixnum n))) + ((1 lda) (1 *))) + lda + (f2cl-lib:fref taup-%data% (i) ((1 *)) taup-%offset%)) + (declare (ignore var-0 var-2 var-3)) + (setf (f2cl-lib:fref a-%data% + (i (f2cl-lib:int-add i 1)) + ((1 lda) (1 *)) + a-%offset%) + var-1) + (setf (f2cl-lib:fref taup-%data% (i) ((1 *)) taup-%offset%) + var-4)) + (setf (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) + (f2cl-lib:fref a-%data% + (i (f2cl-lib:int-add i 1)) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + (i (f2cl-lib:int-add i 1)) + ((1 lda) (1 *)) + a-%offset%) + one) + (dlarf "Right" (f2cl-lib:int-sub m i) (f2cl-lib:int-sub n i) + (f2cl-lib:array-slice a + double-float + (i (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda (f2cl-lib:fref taup-%data% (i) ((1 *)) taup-%offset%) + (f2cl-lib:array-slice a + double-float + ((+ i 1) (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda work) + (setf (f2cl-lib:fref a-%data% + (i (f2cl-lib:int-add i 1)) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%))) + (t + (setf (f2cl-lib:fref taup-%data% (i) ((1 *)) taup-%offset%) + zero)))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlarfg (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1) + (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) + (f2cl-lib:array-slice a + double-float + (i + (min + (the fixnum + (f2cl-lib:int-add i 1)) + (the fixnum n))) + ((1 lda) (1 *))) + lda (f2cl-lib:fref taup-%data% (i) ((1 *)) taup-%offset%)) + (declare (ignore var-0 var-2 var-3)) + (setf (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%) + var-1) + (setf (f2cl-lib:fref taup-%data% (i) ((1 *)) taup-%offset%) + var-4)) + (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) + one) + (dlarf "Right" (f2cl-lib:int-sub m i) + (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1) + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) lda + (f2cl-lib:fref taup-%data% (i) ((1 *)) taup-%offset%) + (f2cl-lib:array-slice a + double-float + ((min (f2cl-lib:int-add i 1) m) i) + ((1 lda) (1 *))) + lda work) + (setf (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) + (cond + ((< i m) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlarfg (f2cl-lib:int-sub m i) + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add i 1) i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:array-slice a + double-float + ((min (f2cl-lib:int-add i 2) m) i) + ((1 lda) (1 *))) + 1 (f2cl-lib:fref tauq-%data% (i) ((1 *)) tauq-%offset%)) + (declare (ignore var-0 var-2 var-3)) + (setf (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add i 1) i) + ((1 lda) (1 *)) + a-%offset%) + var-1) + (setf (f2cl-lib:fref tauq-%data% (i) ((1 *)) tauq-%offset%) + var-4)) + (setf (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add i 1) i) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add i 1) i) + ((1 lda) (1 *)) + a-%offset%) + one) + (dlarf "Left" (f2cl-lib:int-sub m i) (f2cl-lib:int-sub n i) + (f2cl-lib:array-slice a + double-float + ((+ i 1) i) + ((1 lda) (1 *))) + 1 (f2cl-lib:fref tauq-%data% (i) ((1 *)) tauq-%offset%) + (f2cl-lib:array-slice a + double-float + ((+ i 1) (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda work) + (setf (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add i 1) i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%))) + (t + (setf (f2cl-lib:fref tauq-%data% (i) ((1 *)) tauq-%offset%) + zero))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgebd2 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (array double-float (*)) fixnum + (array double-float (*)) (array double-float (*)) + (array double-float (*)) (array double-float (*)) + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlarf fortran-to-lisp::dlarfg + fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgebrd LAPACK} +\pagehead{dgebrd}{dgebrd} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0)) + (declare (type (double-float 1.0 1.0) one)) + (defun dgebrd (m n a lda d e tauq taup work lwork info) + (declare (type (array double-float (*)) work taup tauq e d a) + (type fixnum info lwork lda n m)) + (f2cl-lib:with-multi-array-data + ((a double-float a-%data% a-%offset%) + (d double-float d-%data% d-%offset%) + (e double-float e-%data% e-%offset%) + (tauq double-float tauq-%data% tauq-%offset%) + (taup double-float taup-%data% taup-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((ws 0.0) (i 0) (iinfo 0) (j 0) (ldwrkx 0) (ldwrky 0) (lwkopt 0) + (minmn 0) (nb 0) (nbmin 0) (nx 0) (lquery nil)) + (declare (type (double-float) ws) + (type fixnum i iinfo j ldwrkx ldwrky lwkopt minmn + nb nbmin nx) + (type (member t nil) lquery)) + (setf info 0) + (setf nb + (max (the fixnum 1) + (the fixnum + (ilaenv 1 "DGEBRD" " " m n -1 -1)))) + (setf lwkopt (f2cl-lib:int-mul (f2cl-lib:int-add m n) nb)) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (realpart lwkopt) 'double-float)) + (setf lquery (coerce (= lwork -1) '(member t nil))) + (cond + ((< m 0) + (setf info -1)) + ((< n 0) + (setf info -2)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info -4)) + ((and + (< lwork + (max (the fixnum 1) + (the fixnum m) + (the fixnum n))) + (not lquery)) + (setf info -10))) + (cond + ((< info 0) + (xerbla "DGEBRD" (f2cl-lib:int-sub info)) + (go end_label)) + (lquery + (go end_label))) + (setf minmn (min (the fixnum m) (the fixnum n))) + (cond + ((= minmn 0) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum 1) 'double-float)) + (go end_label))) + (setf ws + (coerce + (the fixnum + (max (the fixnum m) + (the fixnum n))) + 'double-float)) + (setf ldwrkx m) + (setf ldwrky n) + (cond + ((and (> nb 1) (< nb minmn)) + (setf nx + (max (the fixnum nb) + (the fixnum + (ilaenv 3 "DGEBRD" " " m n -1 -1)))) + (cond + ((< nx minmn) + (setf ws + (coerce + (the fixnum + (f2cl-lib:int-mul (f2cl-lib:int-add m n) nb)) + 'double-float)) + (cond + ((< lwork ws) + (setf nbmin (ilaenv 2 "DGEBRD" " " m n -1 -1)) + (cond + ((>= lwork (f2cl-lib:int-mul (f2cl-lib:int-add m n) nbmin)) + (setf nb (the fixnum (truncate lwork (+ m n))))) + (t + (setf nb 1) + (setf nx minmn)))))))) + (t + (setf nx minmn))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i nb)) + ((> i (f2cl-lib:int-add minmn (f2cl-lib:int-sub nx))) nil) + (tagbody + (dlabrd (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) + (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1) nb + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) lda + (f2cl-lib:array-slice d double-float (i) ((1 *))) + (f2cl-lib:array-slice e double-float (i) ((1 *))) + (f2cl-lib:array-slice tauq double-float (i) ((1 *))) + (f2cl-lib:array-slice taup double-float (i) ((1 *))) work ldwrkx + (f2cl-lib:array-slice work + double-float + ((+ (f2cl-lib:int-mul ldwrkx nb) 1)) + ((1 *))) + ldwrky) + (dgemm "No transpose" "Transpose" + (f2cl-lib:int-add (f2cl-lib:int-sub m i nb) 1) + (f2cl-lib:int-add (f2cl-lib:int-sub n i nb) 1) nb (- one) + (f2cl-lib:array-slice a double-float ((+ i nb) i) ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice work + double-float + ((+ (f2cl-lib:int-mul ldwrkx nb) nb 1)) + ((1 *))) + ldwrky one + (f2cl-lib:array-slice a + double-float + ((+ i nb) (f2cl-lib:int-add i nb)) + ((1 lda) (1 *))) + lda) + (dgemm "No transpose" "No transpose" + (f2cl-lib:int-add (f2cl-lib:int-sub m i nb) 1) + (f2cl-lib:int-add (f2cl-lib:int-sub n i nb) 1) nb (- one) + (f2cl-lib:array-slice work double-float ((+ nb 1)) ((1 *))) ldwrkx + (f2cl-lib:array-slice a + double-float + (i (f2cl-lib:int-add i nb)) + ((1 lda) (1 *))) + lda one + (f2cl-lib:array-slice a + double-float + ((+ i nb) (f2cl-lib:int-add i nb)) + ((1 lda) (1 *))) + lda) + (cond + ((>= m n) + (f2cl-lib:fdo (j i (f2cl-lib:int-add j 1)) + ((> j + (f2cl-lib:int-add i nb (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%)) + (setf (f2cl-lib:fref a-%data% + (j (f2cl-lib:int-add j 1)) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref e-%data% (j) ((1 *)) e-%offset%))))) + (t + (f2cl-lib:fdo (j i (f2cl-lib:int-add j 1)) + ((> j + (f2cl-lib:int-add i nb (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%)) + (setf (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add j 1) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref e-%data% (j) ((1 *)) e-%offset%)))))))) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dgebd2 (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) + (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1) + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) lda + (f2cl-lib:array-slice d double-float (i) ((1 *))) + (f2cl-lib:array-slice e double-float (i) ((1 *))) + (f2cl-lib:array-slice tauq double-float (i) ((1 *))) + (f2cl-lib:array-slice taup double-float (i) ((1 *))) work iinfo) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf iinfo var-9)) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) ws) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgebrd + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (array double-float (*)) fixnum + (array double-float (*)) (array double-float (*)) + (array double-float (*)) (array double-float (*)) + (array double-float (*)) fixnum + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dgebd2 fortran-to-lisp::dgemm + fortran-to-lisp::dlabrd fortran-to-lisp::xerbla + fortran-to-lisp::ilaenv)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgeev LAPACK} +\pagehead{dgeev}{dgeev} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0) (one 1.0)) + (declare (type (double-float 0.0 0.0) zero) + (type (double-float 1.0 1.0) one)) + (defun dgeev (jobvl jobvr n a lda wr wi vl ldvl vr ldvr work lwork info) + (declare (type (array double-float (*)) work vr vl wi wr a) + (type fixnum info lwork ldvr ldvl lda n) + (type (simple-array character (*)) jobvr jobvl)) + (f2cl-lib:with-multi-array-data + ((jobvl character jobvl-%data% jobvl-%offset%) + (jobvr character jobvr-%data% jobvr-%offset%) + (a double-float a-%data% a-%offset%) + (wr double-float wr-%data% wr-%offset%) + (wi double-float wi-%data% wi-%offset%) + (vl double-float vl-%data% vl-%offset%) + (vr double-float vr-%data% vr-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((dum (make-array 1 :element-type 'double-float)) + (select (make-array 1 :element-type 't)) (anrm 0.0) (bignum 0.0) + (cs 0.0) (cscale 0.0) (eps 0.0) (r 0.0) (scl 0.0) (smlnum 0.0) + (sn 0.0) (hswork 0) (i 0) (ibal 0) (ierr 0) (ihi 0) (ilo 0) + (itau 0) (iwrk 0) (k 0) (maxb 0) (maxwrk 0) (minwrk 0) (nout 0) + (side + (make-array '(1) :element-type 'character :initial-element #\ )) + (lquery nil) (scalea nil) (wantvl nil) (wantvr nil)) + (declare (type (array double-float (1)) dum) + (type (array (member t nil) (1)) select) + (type (double-float) anrm bignum cs cscale eps r scl smlnum + sn) + (type fixnum hswork i ibal ierr ihi ilo itau iwrk + k maxb maxwrk minwrk nout) + (type (simple-array character (1)) side) + (type (member t nil) lquery scalea wantvl wantvr)) + (setf info 0) + (setf lquery (coerce (= lwork -1) '(member t nil))) + (setf wantvl (lsame jobvl "V")) + (setf wantvr (lsame jobvr "V")) + (cond + ((and (not wantvl) (not (lsame jobvl "N"))) + (setf info -1)) + ((and (not wantvr) (not (lsame jobvr "N"))) + (setf info -2)) + ((< n 0) + (setf info -3)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info -5)) + ((or (< ldvl 1) (and wantvl (< ldvl n))) + (setf info -9)) + ((or (< ldvr 1) (and wantvr (< ldvr n))) + (setf info -11))) + (setf minwrk 1) + (cond + ((and (= info 0) (or (>= lwork 1) lquery)) + (setf maxwrk + (f2cl-lib:int-add (f2cl-lib:int-mul 2 n) + (f2cl-lib:int-mul n + (ilaenv 1 "DGEHRD" " " n + 1 n 0)))) + (cond + ((and (not wantvl) (not wantvr)) + (setf minwrk + (max (the fixnum 1) + (the fixnum (f2cl-lib:int-mul 3 n)))) + (setf maxb + (max + (the fixnum + (ilaenv 8 "DHSEQR" "EN" n 1 n -1)) + (the fixnum 2))) + (setf k + (min (the fixnum maxb) + (the fixnum n) + (the fixnum + (max (the fixnum 2) + (the fixnum + (ilaenv 4 "DHSEQR" "EN" n 1 n -1)))))) + (setf hswork + (max + (the fixnum + (f2cl-lib:int-mul k (f2cl-lib:int-add k 2))) + (the fixnum (f2cl-lib:int-mul 2 n)))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum (f2cl-lib:int-add n 1)) + (the fixnum + (f2cl-lib:int-add n hswork))))) + (t + (setf minwrk + (max (the fixnum 1) + (the fixnum (f2cl-lib:int-mul 4 n)))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 2 n) + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + (ilaenv 1 "DORGHR" " " n 1 n + -1)))))) + (setf maxb + (max + (the fixnum + (ilaenv 8 "DHSEQR" "SV" n 1 n -1)) + (the fixnum 2))) + (setf k + (min (the fixnum maxb) + (the fixnum n) + (the fixnum + (max (the fixnum 2) + (the fixnum + (ilaenv 4 "DHSEQR" "SV" n 1 n -1)))))) + (setf hswork + (max + (the fixnum + (f2cl-lib:int-mul k (f2cl-lib:int-add k 2))) + (the fixnum (f2cl-lib:int-mul 2 n)))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum (f2cl-lib:int-add n 1)) + (the fixnum (f2cl-lib:int-add n hswork)))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum (f2cl-lib:int-mul 4 n)))))) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum maxwrk) 'double-float)))) + (cond + ((and (< lwork minwrk) (not lquery)) + (setf info -13))) + (cond + ((/= info 0) + (xerbla "DGEEV " (f2cl-lib:int-sub info)) + (go end_label)) + (lquery + (go end_label))) + (if (= n 0) (go end_label)) + (setf eps (dlamch "P")) + (setf smlnum (dlamch "S")) + (setf bignum (/ one smlnum)) + (multiple-value-bind (var-0 var-1) + (dlabad smlnum bignum) + (declare (ignore)) + (setf smlnum var-0) + (setf bignum var-1)) + (setf smlnum (/ (f2cl-lib:fsqrt smlnum) eps)) + (setf bignum (/ one smlnum)) + (setf anrm (dlange "M" n n a lda dum)) + (setf scalea nil) + (cond + ((and (> anrm zero) (< anrm smlnum)) + (setf scalea t) + (setf cscale smlnum)) + ((> anrm bignum) + (setf scalea t) + (setf cscale bignum))) + (if scalea + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dlascl "G" 0 0 anrm cscale n n a lda ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf ierr var-9))) + (setf ibal 1) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgebal "B" n a lda ilo ihi + (f2cl-lib:array-slice work double-float (ibal) ((1 *))) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-6)) + (setf ilo var-4) + (setf ihi var-5) + (setf ierr var-7)) + (setf itau (f2cl-lib:int-add ibal n)) + (setf iwrk (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dgehrd n ilo ihi a lda + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (iwrk) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwrk) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)) + (setf ierr var-8)) + (cond + (wantvl + (f2cl-lib:f2cl-set-string side "L" (string 1)) + (dlacpy "L" n n a lda vl ldvl) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dorghr n ilo ihi vl ldvl + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (iwrk) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwrk) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)) + (setf ierr var-8)) + (setf iwrk itau) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 + var-10 var-11 var-12 var-13) + (dhseqr "S" "V" n ilo ihi a lda wr wi vl ldvl + (f2cl-lib:array-slice work double-float (iwrk) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwrk) 1) info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12)) + (setf info var-13)) + (cond + (wantvr + (f2cl-lib:f2cl-set-string side "B" (string 1)) + (dlacpy "F" n n vl ldvl vr ldvr)))) + (wantvr + (f2cl-lib:f2cl-set-string side "R" (string 1)) + (dlacpy "L" n n a lda vr ldvr) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dorghr n ilo ihi vr ldvr + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (iwrk) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwrk) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)) + (setf ierr var-8)) + (setf iwrk itau) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 + var-10 var-11 var-12 var-13) + (dhseqr "S" "V" n ilo ihi a lda wr wi vr ldvr + (f2cl-lib:array-slice work double-float (iwrk) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwrk) 1) info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12)) + (setf info var-13))) + (t + (setf iwrk itau) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 + var-10 var-11 var-12 var-13) + (dhseqr "E" "N" n ilo ihi a lda wr wi vr ldvr + (f2cl-lib:array-slice work double-float (iwrk) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwrk) 1) info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12)) + (setf info var-13)))) + (if (> info 0) (go label50)) + (cond + ((or wantvl wantvr) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 + var-10 var-11 var-12 var-13) + (dtrevc side "B" select n a lda vl ldvl vr ldvr n nout + (f2cl-lib:array-slice work double-float (iwrk) ((1 *))) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-12)) + (setf nout var-11) + (setf ierr var-13)))) + (cond + (wantvl + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dgebak "B" "L" n ilo ihi + (f2cl-lib:array-slice work double-float (ibal) ((1 *))) n vl + ldvl ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf ierr var-9)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (cond + ((= (f2cl-lib:fref wi (i) ((1 *))) zero) + (setf scl + (/ one + (dnrm2 n + (f2cl-lib:array-slice vl + double-float + (1 i) + ((1 ldvl) (1 *))) + 1))) + (dscal n scl + (f2cl-lib:array-slice vl + double-float + (1 i) + ((1 ldvl) (1 *))) + 1)) + ((> (f2cl-lib:fref wi (i) ((1 *))) zero) + (setf scl + (/ one + (dlapy2 + (dnrm2 n + (f2cl-lib:array-slice vl + double-float + (1 i) + ((1 ldvl) (1 *))) + 1) + (dnrm2 n + (f2cl-lib:array-slice vl + double-float + (1 (f2cl-lib:int-add i 1)) + ((1 ldvl) (1 *))) + 1)))) + (dscal n scl + (f2cl-lib:array-slice vl + double-float + (1 i) + ((1 ldvl) (1 *))) + 1) + (dscal n scl + (f2cl-lib:array-slice vl + double-float + (1 (f2cl-lib:int-add i 1)) + ((1 ldvl) (1 *))) + 1) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add iwrk k) + 1)) + ((1 *)) + work-%offset%) + (+ + (expt + (f2cl-lib:fref vl-%data% + (k i) + ((1 ldvl) (1 *)) + vl-%offset%) + 2) + (expt + (f2cl-lib:fref vl-%data% + (k (f2cl-lib:int-add i 1)) + ((1 ldvl) (1 *)) + vl-%offset%) + 2))))) + (setf k + (idamax n + (f2cl-lib:array-slice work + double-float + (iwrk) + ((1 *))) + 1)) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlartg + (f2cl-lib:fref vl-%data% + (k i) + ((1 ldvl) (1 *)) + vl-%offset%) + (f2cl-lib:fref vl-%data% + (k (f2cl-lib:int-add i 1)) + ((1 ldvl) (1 *)) + vl-%offset%) + cs sn r) + (declare (ignore var-0 var-1)) + (setf cs var-2) + (setf sn var-3) + (setf r var-4)) + (drot n + (f2cl-lib:array-slice vl + double-float + (1 i) + ((1 ldvl) (1 *))) + 1 + (f2cl-lib:array-slice vl + double-float + (1 (f2cl-lib:int-add i 1)) + ((1 ldvl) (1 *))) + 1 cs sn) + (setf (f2cl-lib:fref vl-%data% + (k (f2cl-lib:int-add i 1)) + ((1 ldvl) (1 *)) + vl-%offset%) + zero))))))) + (cond + (wantvr + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dgebak "B" "R" n ilo ihi + (f2cl-lib:array-slice work double-float (ibal) ((1 *))) n vr + ldvr ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf ierr var-9)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (cond + ((= (f2cl-lib:fref wi (i) ((1 *))) zero) + (setf scl + (/ one + (dnrm2 n + (f2cl-lib:array-slice vr + double-float + (1 i) + ((1 ldvr) (1 *))) + 1))) + (dscal n scl + (f2cl-lib:array-slice vr + double-float + (1 i) + ((1 ldvr) (1 *))) + 1)) + ((> (f2cl-lib:fref wi (i) ((1 *))) zero) + (setf scl + (/ one + (dlapy2 + (dnrm2 n + (f2cl-lib:array-slice vr + double-float + (1 i) + ((1 ldvr) (1 *))) + 1) + (dnrm2 n + (f2cl-lib:array-slice vr + double-float + (1 (f2cl-lib:int-add i 1)) + ((1 ldvr) (1 *))) + 1)))) + (dscal n scl + (f2cl-lib:array-slice vr + double-float + (1 i) + ((1 ldvr) (1 *))) + 1) + (dscal n scl + (f2cl-lib:array-slice vr + double-float + (1 (f2cl-lib:int-add i 1)) + ((1 ldvr) (1 *))) + 1) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add iwrk k) + 1)) + ((1 *)) + work-%offset%) + (+ + (expt + (f2cl-lib:fref vr-%data% + (k i) + ((1 ldvr) (1 *)) + vr-%offset%) + 2) + (expt + (f2cl-lib:fref vr-%data% + (k (f2cl-lib:int-add i 1)) + ((1 ldvr) (1 *)) + vr-%offset%) + 2))))) + (setf k + (idamax n + (f2cl-lib:array-slice work + double-float + (iwrk) + ((1 *))) + 1)) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlartg + (f2cl-lib:fref vr-%data% + (k i) + ((1 ldvr) (1 *)) + vr-%offset%) + (f2cl-lib:fref vr-%data% + (k (f2cl-lib:int-add i 1)) + ((1 ldvr) (1 *)) + vr-%offset%) + cs sn r) + (declare (ignore var-0 var-1)) + (setf cs var-2) + (setf sn var-3) + (setf r var-4)) + (drot n + (f2cl-lib:array-slice vr + double-float + (1 i) + ((1 ldvr) (1 *))) + 1 + (f2cl-lib:array-slice vr + double-float + (1 (f2cl-lib:int-add i 1)) + ((1 ldvr) (1 *))) + 1 cs sn) + (setf (f2cl-lib:fref vr-%data% + (k (f2cl-lib:int-add i 1)) + ((1 ldvr) (1 *)) + vr-%offset%) + zero))))))) + label50 + (cond + (scalea + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dlascl "G" 0 0 cscale anrm (f2cl-lib:int-sub n info) 1 + (f2cl-lib:array-slice wr double-float ((+ info 1)) ((1 *))) + (max (the fixnum (f2cl-lib:int-sub n info)) + (the fixnum 1)) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf ierr var-9)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dlascl "G" 0 0 cscale anrm (f2cl-lib:int-sub n info) 1 + (f2cl-lib:array-slice wi double-float ((+ info 1)) ((1 *))) + (max (the fixnum (f2cl-lib:int-sub n info)) + (the fixnum 1)) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf ierr var-9)) + (cond + ((> info 0) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dlascl "G" 0 0 cscale anrm (f2cl-lib:int-sub ilo 1) 1 wr n + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8)) + (setf ierr var-9)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dlascl "G" 0 0 cscale anrm (f2cl-lib:int-sub ilo 1) 1 wi n + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8)) + (setf ierr var-9)))))) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum maxwrk) 'double-float)) + end_label + (return + (values nil nil nil nil nil nil nil nil nil nil nil nil nil info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgeev fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + (simple-array character (1)) + fixnum (array double-float (*)) + fixnum (array double-float (*)) + (array double-float (*)) (array double-float (*)) + fixnum (array double-float (*)) + fixnum (array double-float (*)) + fixnum + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::drot fortran-to-lisp::dlartg + fortran-to-lisp::idamax fortran-to-lisp::dlapy2 + fortran-to-lisp::dscal fortran-to-lisp::dnrm2 + fortran-to-lisp::dgebak fortran-to-lisp::dtrevc + fortran-to-lisp::dhseqr fortran-to-lisp::dorghr + fortran-to-lisp::dlacpy fortran-to-lisp::dgehrd + fortran-to-lisp::dgebal fortran-to-lisp::dlascl + fortran-to-lisp::dlange fortran-to-lisp::dlabad + fortran-to-lisp::dlamch fortran-to-lisp::xerbla + fortran-to-lisp::ilaenv fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgeevx LAPACK} +\pagehead{dgeevx}{dgeevx} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0) (one 1.0)) + (declare (type (double-float 0.0 0.0) zero) + (type (double-float 1.0 1.0) one)) + (defun dgeevx + (balanc jobvl jobvr sense n a lda wr wi vl ldvl vr ldvr ilo ihi scale + abnrm rconde rcondv work lwork iwork info) + (declare (type (array fixnum (*)) iwork) + (type (double-float) abnrm) + (type (array double-float (*)) work rcondv rconde scale vr vl wi + wr a) + (type fixnum info lwork ihi ilo ldvr ldvl lda n) + (type (simple-array character (*)) sense jobvr jobvl balanc)) + (f2cl-lib:with-multi-array-data + ((balanc character balanc-%data% balanc-%offset%) + (jobvl character jobvl-%data% jobvl-%offset%) + (jobvr character jobvr-%data% jobvr-%offset%) + (sense character sense-%data% sense-%offset%) + (a double-float a-%data% a-%offset%) + (wr double-float wr-%data% wr-%offset%) + (wi double-float wi-%data% wi-%offset%) + (vl double-float vl-%data% vl-%offset%) + (vr double-float vr-%data% vr-%offset%) + (scale double-float scale-%data% scale-%offset%) + (rconde double-float rconde-%data% rconde-%offset%) + (rcondv double-float rcondv-%data% rcondv-%offset%) + (work double-float work-%data% work-%offset%) + (iwork fixnum iwork-%data% iwork-%offset%)) + (prog ((dum (make-array 1 :element-type 'double-float)) + (select (make-array 1 :element-type 't)) (anrm 0.0) (bignum 0.0) + (cs 0.0) (cscale 0.0) (eps 0.0) (r 0.0) (scl 0.0) (smlnum 0.0) + (sn 0.0) (hswork 0) (i 0) (icond 0) (ierr 0) (itau 0) (iwrk 0) + (k 0) (maxb 0) (maxwrk 0) (minwrk 0) (nout 0) + (job + (make-array '(1) :element-type 'character :initial-element #\ )) + (side + (make-array '(1) :element-type 'character :initial-element #\ )) + (lquery nil) (scalea nil) (wantvl nil) (wantvr nil) (wntsnb nil) + (wntsne nil) (wntsnn nil) (wntsnv nil)) + (declare (type (array double-float (1)) dum) + (type (array (member t nil) (1)) select) + (type (double-float) anrm bignum cs cscale eps r scl smlnum + sn) + (type fixnum hswork i icond ierr itau iwrk k maxb + maxwrk minwrk nout) + (type (simple-array character (1)) job side) + (type (member t nil) lquery scalea wantvl wantvr wntsnb + wntsne wntsnn wntsnv)) + (setf info 0) + (setf lquery (coerce (= lwork -1) '(member t nil))) + (setf wantvl (lsame jobvl "V")) + (setf wantvr (lsame jobvr "V")) + (setf wntsnn (lsame sense "N")) + (setf wntsne (lsame sense "E")) + (setf wntsnv (lsame sense "V")) + (setf wntsnb (lsame sense "B")) + (cond + ((not + (or (lsame balanc "N") + (lsame balanc "S") + (lsame balanc "P") + (lsame balanc "B"))) + (setf info -1)) + ((and (not wantvl) (not (lsame jobvl "N"))) + (setf info -2)) + ((and (not wantvr) (not (lsame jobvr "N"))) + (setf info -3)) + ((or (not (or wntsnn wntsne wntsnb wntsnv)) + (and (or wntsne wntsnb) (not (and wantvl wantvr)))) + (setf info -4)) + ((< n 0) + (setf info -5)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info -7)) + ((or (< ldvl 1) (and wantvl (< ldvl n))) + (setf info -11)) + ((or (< ldvr 1) (and wantvr (< ldvr n))) + (setf info -13))) + (setf minwrk 1) + (cond + ((and (= info 0) (or (>= lwork 1) lquery)) + (setf maxwrk + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv 1 "DGEHRD" " " n + 1 n 0)))) + (cond + ((and (not wantvl) (not wantvr)) + (setf minwrk + (max (the fixnum 1) + (the fixnum (f2cl-lib:int-mul 2 n)))) + (if (not wntsnn) + (setf minwrk + (max (the fixnum minwrk) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul n n) + (f2cl-lib:int-mul 6 + n)))))) + (setf maxb + (max + (the fixnum + (ilaenv 8 "DHSEQR" "SN" n 1 n -1)) + (the fixnum 2))) + (cond + (wntsnn + (setf k + (min (the fixnum maxb) + (the fixnum n) + (the fixnum + (max (the fixnum 2) + (the fixnum + (ilaenv 4 "DHSEQR" "EN" n 1 n + -1))))))) + (t + (setf k + (min (the fixnum maxb) + (the fixnum n) + (the fixnum + (max (the fixnum 2) + (the fixnum + (ilaenv 4 "DHSEQR" "SN" n 1 n + -1)))))))) + (setf hswork + (max + (the fixnum + (f2cl-lib:int-mul k (f2cl-lib:int-add k 2))) + (the fixnum (f2cl-lib:int-mul 2 n)))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum 1) + (the fixnum hswork))) + (if (not wntsnn) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul n n) + (f2cl-lib:int-mul 6 + n))))))) + (t + (setf minwrk + (max (the fixnum 1) + (the fixnum (f2cl-lib:int-mul 3 n)))) + (if (and (not wntsnn) (not wntsne)) + (setf minwrk + (max (the fixnum minwrk) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul n n) + (f2cl-lib:int-mul 6 + n)))))) + (setf maxb + (max + (the fixnum + (ilaenv 8 "DHSEQR" "SN" n 1 n -1)) + (the fixnum 2))) + (setf k + (min (the fixnum maxb) + (the fixnum n) + (the fixnum + (max (the fixnum 2) + (the fixnum + (ilaenv 4 "DHSEQR" "EN" n 1 n -1)))))) + (setf hswork + (max + (the fixnum + (f2cl-lib:int-mul k (f2cl-lib:int-add k 2))) + (the fixnum (f2cl-lib:int-mul 2 n)))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum 1) + (the fixnum hswork))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum + (f2cl-lib:int-add n + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + (ilaenv 1 "DORGHR" " " n 1 n + -1)))))) + (if (and (not wntsnn) (not wntsne)) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul n n) + (f2cl-lib:int-mul 6 + n)))))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum (f2cl-lib:int-mul 3 n)) + (the fixnum 1))))) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum maxwrk) 'double-float)))) + (cond + ((and (< lwork minwrk) (not lquery)) + (setf info -21))) + (cond + ((/= info 0) + (xerbla "DGEEVX" (f2cl-lib:int-sub info)) + (go end_label)) + (lquery + (go end_label))) + (if (= n 0) (go end_label)) + (setf eps (dlamch "P")) + (setf smlnum (dlamch "S")) + (setf bignum (/ one smlnum)) + (multiple-value-bind (var-0 var-1) + (dlabad smlnum bignum) + (declare (ignore)) + (setf smlnum var-0) + (setf bignum var-1)) + (setf smlnum (/ (f2cl-lib:fsqrt smlnum) eps)) + (setf bignum (/ one smlnum)) + (setf icond 0) + (setf anrm (dlange "M" n n a lda dum)) + (setf scalea nil) + (cond + ((and (> anrm zero) (< anrm smlnum)) + (setf scalea t) + (setf cscale smlnum)) + ((> anrm bignum) + (setf scalea t) + (setf cscale bignum))) + (if scalea + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dlascl "G" 0 0 anrm cscale n n a lda ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf ierr var-9))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgebal balanc n a lda ilo ihi scale ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-6)) + (setf ilo var-4) + (setf ihi var-5) + (setf ierr var-7)) + (setf abnrm (dlange "1" n n a lda dum)) + (cond + (scalea + (setf (f2cl-lib:fref dum (1) ((1 1))) abnrm) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dlascl "G" 0 0 cscale anrm 1 1 dum 1 ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf ierr var-9)) + (setf abnrm (f2cl-lib:fref dum (1) ((1 1)))))) + (setf itau 1) + (setf iwrk (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dgehrd n ilo ihi a lda + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (iwrk) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwrk) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)) + (setf ierr var-8)) + (cond + (wantvl + (f2cl-lib:f2cl-set-string side "L" (string 1)) + (dlacpy "L" n n a lda vl ldvl) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dorghr n ilo ihi vl ldvl + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (iwrk) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwrk) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)) + (setf ierr var-8)) + (setf iwrk itau) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 + var-10 var-11 var-12 var-13) + (dhseqr "S" "V" n ilo ihi a lda wr wi vl ldvl + (f2cl-lib:array-slice work double-float (iwrk) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwrk) 1) info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12)) + (setf info var-13)) + (cond + (wantvr + (f2cl-lib:f2cl-set-string side "B" (string 1)) + (dlacpy "F" n n vl ldvl vr ldvr)))) + (wantvr + (f2cl-lib:f2cl-set-string side "R" (string 1)) + (dlacpy "L" n n a lda vr ldvr) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dorghr n ilo ihi vr ldvr + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (iwrk) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwrk) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)) + (setf ierr var-8)) + (setf iwrk itau) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 + var-10 var-11 var-12 var-13) + (dhseqr "S" "V" n ilo ihi a lda wr wi vr ldvr + (f2cl-lib:array-slice work double-float (iwrk) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwrk) 1) info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12)) + (setf info var-13))) + (t + (cond + (wntsnn + (f2cl-lib:f2cl-set-string job "E" (string 1))) + (t + (f2cl-lib:f2cl-set-string job "S" (string 1)))) + (setf iwrk itau) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 + var-10 var-11 var-12 var-13) + (dhseqr job "N" n ilo ihi a lda wr wi vr ldvr + (f2cl-lib:array-slice work double-float (iwrk) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwrk) 1) info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12)) + (setf info var-13)))) + (if (> info 0) (go label50)) + (cond + ((or wantvl wantvr) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 + var-10 var-11 var-12 var-13) + (dtrevc side "B" select n a lda vl ldvl vr ldvr n nout + (f2cl-lib:array-slice work double-float (iwrk) ((1 *))) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-12)) + (setf nout var-11) + (setf ierr var-13)))) + (cond + ((not wntsnn) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 + var-10 var-11 var-12 var-13 var-14 var-15 var-16 var-17) + (dtrsna sense "A" select n a lda vl ldvl vr ldvr rconde rcondv n + nout (f2cl-lib:array-slice work double-float (iwrk) ((1 *))) n + iwork icond) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-14 var-15 + var-16)) + (setf nout var-13) + (setf icond var-17)))) + (cond + (wantvl + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dgebak balanc "L" n ilo ihi scale n vl ldvl ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf ierr var-9)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (cond + ((= (f2cl-lib:fref wi (i) ((1 *))) zero) + (setf scl + (/ one + (dnrm2 n + (f2cl-lib:array-slice vl + double-float + (1 i) + ((1 ldvl) (1 *))) + 1))) + (dscal n scl + (f2cl-lib:array-slice vl + double-float + (1 i) + ((1 ldvl) (1 *))) + 1)) + ((> (f2cl-lib:fref wi (i) ((1 *))) zero) + (setf scl + (/ one + (dlapy2 + (dnrm2 n + (f2cl-lib:array-slice vl + double-float + (1 i) + ((1 ldvl) (1 *))) + 1) + (dnrm2 n + (f2cl-lib:array-slice vl + double-float + (1 (f2cl-lib:int-add i 1)) + ((1 ldvl) (1 *))) + 1)))) + (dscal n scl + (f2cl-lib:array-slice vl + double-float + (1 i) + ((1 ldvl) (1 *))) + 1) + (dscal n scl + (f2cl-lib:array-slice vl + double-float + (1 (f2cl-lib:int-add i 1)) + ((1 ldvl) (1 *))) + 1) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% + (k) + ((1 *)) + work-%offset%) + (+ + (expt + (f2cl-lib:fref vl-%data% + (k i) + ((1 ldvl) (1 *)) + vl-%offset%) + 2) + (expt + (f2cl-lib:fref vl-%data% + (k (f2cl-lib:int-add i 1)) + ((1 ldvl) (1 *)) + vl-%offset%) + 2))))) + (setf k (idamax n work 1)) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlartg + (f2cl-lib:fref vl-%data% + (k i) + ((1 ldvl) (1 *)) + vl-%offset%) + (f2cl-lib:fref vl-%data% + (k (f2cl-lib:int-add i 1)) + ((1 ldvl) (1 *)) + vl-%offset%) + cs sn r) + (declare (ignore var-0 var-1)) + (setf cs var-2) + (setf sn var-3) + (setf r var-4)) + (drot n + (f2cl-lib:array-slice vl + double-float + (1 i) + ((1 ldvl) (1 *))) + 1 + (f2cl-lib:array-slice vl + double-float + (1 (f2cl-lib:int-add i 1)) + ((1 ldvl) (1 *))) + 1 cs sn) + (setf (f2cl-lib:fref vl-%data% + (k (f2cl-lib:int-add i 1)) + ((1 ldvl) (1 *)) + vl-%offset%) + zero))))))) + (cond + (wantvr + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dgebak balanc "R" n ilo ihi scale n vr ldvr ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf ierr var-9)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (cond + ((= (f2cl-lib:fref wi (i) ((1 *))) zero) + (setf scl + (/ one + (dnrm2 n + (f2cl-lib:array-slice vr + double-float + (1 i) + ((1 ldvr) (1 *))) + 1))) + (dscal n scl + (f2cl-lib:array-slice vr + double-float + (1 i) + ((1 ldvr) (1 *))) + 1)) + ((> (f2cl-lib:fref wi (i) ((1 *))) zero) + (setf scl + (/ one + (dlapy2 + (dnrm2 n + (f2cl-lib:array-slice vr + double-float + (1 i) + ((1 ldvr) (1 *))) + 1) + (dnrm2 n + (f2cl-lib:array-slice vr + double-float + (1 (f2cl-lib:int-add i 1)) + ((1 ldvr) (1 *))) + 1)))) + (dscal n scl + (f2cl-lib:array-slice vr + double-float + (1 i) + ((1 ldvr) (1 *))) + 1) + (dscal n scl + (f2cl-lib:array-slice vr + double-float + (1 (f2cl-lib:int-add i 1)) + ((1 ldvr) (1 *))) + 1) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% + (k) + ((1 *)) + work-%offset%) + (+ + (expt + (f2cl-lib:fref vr-%data% + (k i) + ((1 ldvr) (1 *)) + vr-%offset%) + 2) + (expt + (f2cl-lib:fref vr-%data% + (k (f2cl-lib:int-add i 1)) + ((1 ldvr) (1 *)) + vr-%offset%) + 2))))) + (setf k (idamax n work 1)) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlartg + (f2cl-lib:fref vr-%data% + (k i) + ((1 ldvr) (1 *)) + vr-%offset%) + (f2cl-lib:fref vr-%data% + (k (f2cl-lib:int-add i 1)) + ((1 ldvr) (1 *)) + vr-%offset%) + cs sn r) + (declare (ignore var-0 var-1)) + (setf cs var-2) + (setf sn var-3) + (setf r var-4)) + (drot n + (f2cl-lib:array-slice vr + double-float + (1 i) + ((1 ldvr) (1 *))) + 1 + (f2cl-lib:array-slice vr + double-float + (1 (f2cl-lib:int-add i 1)) + ((1 ldvr) (1 *))) + 1 cs sn) + (setf (f2cl-lib:fref vr-%data% + (k (f2cl-lib:int-add i 1)) + ((1 ldvr) (1 *)) + vr-%offset%) + zero))))))) + label50 + (cond + (scalea + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dlascl "G" 0 0 cscale anrm (f2cl-lib:int-sub n info) 1 + (f2cl-lib:array-slice wr double-float ((+ info 1)) ((1 *))) + (max (the fixnum (f2cl-lib:int-sub n info)) + (the fixnum 1)) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf ierr var-9)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dlascl "G" 0 0 cscale anrm (f2cl-lib:int-sub n info) 1 + (f2cl-lib:array-slice wi double-float ((+ info 1)) ((1 *))) + (max (the fixnum (f2cl-lib:int-sub n info)) + (the fixnum 1)) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf ierr var-9)) + (cond + ((= info 0) + (if (and (or wntsnv wntsnb) (= icond 0)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dlascl "G" 0 0 cscale anrm n 1 rcondv n ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8)) + (setf ierr var-9)))) + (t + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dlascl "G" 0 0 cscale anrm (f2cl-lib:int-sub ilo 1) 1 wr n + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8)) + (setf ierr var-9)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dlascl "G" 0 0 cscale anrm (f2cl-lib:int-sub ilo 1) 1 wi n + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8)) + (setf ierr var-9)))))) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum maxwrk) 'double-float)) + end_label + (return + (values nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + ilo + ihi + nil + abnrm + nil + nil + nil + nil + nil + info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgeevx + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + (simple-array character (1)) + (simple-array character (1)) + (simple-array character (1)) + fixnum (array double-float (*)) + fixnum (array double-float (*)) + (array double-float (*)) (array double-float (*)) + fixnum (array double-float (*)) + fixnum fixnum + fixnum (array double-float (*)) + (double-float) (array double-float (*)) + (array double-float (*)) (array double-float (*)) + fixnum + (array fixnum (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::ilo fortran-to-lisp::ihi nil + fortran-to-lisp::abnrm nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dtrsna fortran-to-lisp::drot + fortran-to-lisp::dlartg fortran-to-lisp::idamax + fortran-to-lisp::dlapy2 fortran-to-lisp::dscal + fortran-to-lisp::dnrm2 fortran-to-lisp::dgebak + fortran-to-lisp::dtrevc fortran-to-lisp::dhseqr + fortran-to-lisp::dorghr fortran-to-lisp::dlacpy + fortran-to-lisp::dgehrd fortran-to-lisp::dgebal + fortran-to-lisp::dlascl fortran-to-lisp::dlange + fortran-to-lisp::dlabad fortran-to-lisp::dlamch + fortran-to-lisp::xerbla fortran-to-lisp::ilaenv + fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgehd2 LAPACK} +\pagehead{dgehd2}{dgehd2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0)) + (declare (type (double-float 1.0 1.0) one)) + (defun dgehd2 (n ilo ihi a lda tau work info) + (declare (type (array double-float (*)) work tau a) + (type fixnum info lda ihi ilo n)) + (f2cl-lib:with-multi-array-data + ((a double-float a-%data% a-%offset%) + (tau double-float tau-%data% tau-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((aii 0.0) (i 0)) + (declare (type (double-float) aii) (type fixnum i)) + (setf info 0) + (cond + ((< n 0) + (setf info -1)) + ((or (< ilo 1) + (> ilo + (max (the fixnum 1) (the fixnum n)))) + (setf info -2)) + ((or + (< ihi (min (the fixnum ilo) (the fixnum n))) + (> ihi n)) + (setf info -3)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info -5))) + (cond + ((/= info 0) + (xerbla "DGEHD2" (f2cl-lib:int-sub info)) + (go end_label))) + (f2cl-lib:fdo (i ilo (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add ihi (f2cl-lib:int-sub 1))) nil) + (tagbody + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlarfg (f2cl-lib:int-sub ihi i) + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add i 1) i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:array-slice a + double-float + ((min (f2cl-lib:int-add i 2) n) i) + ((1 lda) (1 *))) + 1 (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%)) + (declare (ignore var-0 var-2 var-3)) + (setf (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add i 1) i) + ((1 lda) (1 *)) + a-%offset%) + var-1) + (setf (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%) var-4)) + (setf aii + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add i 1) i) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add i 1) i) + ((1 lda) (1 *)) + a-%offset%) + one) + (dlarf "Right" ihi (f2cl-lib:int-sub ihi i) + (f2cl-lib:array-slice a double-float ((+ i 1) i) ((1 lda) (1 *))) + 1 (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%) + (f2cl-lib:array-slice a + double-float + (1 (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda work) + (dlarf "Left" (f2cl-lib:int-sub ihi i) (f2cl-lib:int-sub n i) + (f2cl-lib:array-slice a double-float ((+ i 1) i) ((1 lda) (1 *))) + 1 (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%) + (f2cl-lib:array-slice a + double-float + ((+ i 1) (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda work) + (setf (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add i 1) i) + ((1 lda) (1 *)) + a-%offset%) + aii))) + end_label + (return (values nil nil nil nil nil nil nil info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgehd2 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + fixnum (array double-float (*)) + fixnum (array double-float (*)) + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlarf fortran-to-lisp::dlarfg + fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgehrd LAPACK} +\pagehead{dgehrd}{dgehrd} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((nbmax 64) (ldt (+ nbmax 1)) (zero 0.0) (one 1.0)) + (declare (type (fixnum 64 64) nbmax) + (type fixnum ldt) + (type (double-float 0.0 0.0) zero) + (type (double-float 1.0 1.0) one)) + (defun dgehrd (n ilo ihi a lda tau work lwork info) + (declare (type (array double-float (*)) work tau a) + (type fixnum info lwork lda ihi ilo n)) + (f2cl-lib:with-multi-array-data + ((a double-float a-%data% a-%offset%) + (tau double-float tau-%data% tau-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((ei 0.0) (i 0) (ib 0) (iinfo 0) (iws 0) (ldwork 0) (lwkopt 0) + (nb 0) (nbmin 0) (nh 0) (nx 0) (lquery nil) + (t$ + (make-array (the fixnum (reduce #'* (list ldt nbmax))) + :element-type 'double-float))) + (declare (type (array double-float (*)) t$) + (type (double-float) ei) + (type fixnum i ib iinfo iws ldwork lwkopt nb + nbmin nh nx) + (type (member t nil) lquery)) + (setf info 0) + (setf nb + (min (the fixnum nbmax) + (the fixnum + (ilaenv 1 "DGEHRD" " " n ilo ihi -1)))) + (setf lwkopt (f2cl-lib:int-mul n nb)) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum lwkopt) 'double-float)) + (setf lquery (coerce (= lwork -1) '(member t nil))) + (cond + ((< n 0) + (setf info -1)) + ((or (< ilo 1) + (> ilo + (max (the fixnum 1) (the fixnum n)))) + (setf info -2)) + ((or + (< ihi (min (the fixnum ilo) (the fixnum n))) + (> ihi n)) + (setf info -3)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info -5)) + ((and + (< lwork (max (the fixnum 1) (the fixnum n))) + (not lquery)) + (setf info -8))) + (cond + ((/= info 0) + (xerbla "DGEHRD" (f2cl-lib:int-sub info)) + (go end_label)) + (lquery + (go end_label))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add ilo (f2cl-lib:int-sub 1))) nil) + (tagbody + (setf (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%) zero))) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum ihi)) + (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add n (f2cl-lib:int-sub 1))) nil) + (tagbody + (setf (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%) zero))) + (setf nh (f2cl-lib:int-add (f2cl-lib:int-sub ihi ilo) 1)) + (cond + ((<= nh 1) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum 1) 'double-float)) + (go end_label))) + (setf nb + (min (the fixnum nbmax) + (the fixnum + (ilaenv 1 "DGEHRD" " " n ilo ihi -1)))) + (setf nbmin 2) + (setf iws 1) + (cond + ((and (> nb 1) (< nb nh)) + (setf nx + (max (the fixnum nb) + (the fixnum + (ilaenv 3 "DGEHRD" " " n ilo ihi -1)))) + (cond + ((< nx nh) + (setf iws (f2cl-lib:int-mul n nb)) + (cond + ((< lwork iws) + (setf nbmin + (max (the fixnum 2) + (the fixnum + (ilaenv 2 "DGEHRD" " " n ilo ihi -1)))) + (cond + ((>= lwork (f2cl-lib:int-mul n nbmin)) + (setf nb (the fixnum (truncate lwork n)))) + (t + (setf nb 1))))))))) + (setf ldwork n) + (cond + ((or (< nb nbmin) (>= nb nh)) + (setf i ilo)) + (t + (f2cl-lib:fdo (i ilo (f2cl-lib:int-add i nb)) + ((> i + (f2cl-lib:int-add ihi + (f2cl-lib:int-sub 1) + (f2cl-lib:int-sub nx))) + nil) + (tagbody + (setf ib + (min (the fixnum nb) + (the fixnum (f2cl-lib:int-sub ihi i)))) + (dlahrd ihi i ib + (f2cl-lib:array-slice a double-float (1 i) ((1 lda) (1 *))) lda + (f2cl-lib:array-slice tau double-float (i) ((1 *))) t$ ldt work + ldwork) + (setf ei + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add i ib) + (f2cl-lib:int-sub + (f2cl-lib:int-add i ib) + 1)) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add i ib) + (f2cl-lib:int-sub (f2cl-lib:int-add i ib) + 1)) + ((1 lda) (1 *)) + a-%offset%) + one) + (dgemm "No transpose" "Transpose" ihi + (f2cl-lib:int-add (f2cl-lib:int-sub ihi i ib) 1) ib (- one) + work ldwork + (f2cl-lib:array-slice a + double-float + ((+ i ib) i) + ((1 lda) (1 *))) + lda one + (f2cl-lib:array-slice a + double-float + (1 (f2cl-lib:int-add i ib)) + ((1 lda) (1 *))) + lda) + (setf (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add i ib) + (f2cl-lib:int-sub (f2cl-lib:int-add i ib) + 1)) + ((1 lda) (1 *)) + a-%offset%) + ei) + (dlarfb "Left" "Transpose" "Forward" "Columnwise" + (f2cl-lib:int-sub ihi i) + (f2cl-lib:int-add (f2cl-lib:int-sub n i ib) 1) ib + (f2cl-lib:array-slice a + double-float + ((+ i 1) i) + ((1 lda) (1 *))) + lda t$ ldt + (f2cl-lib:array-slice a + double-float + ((+ i 1) (f2cl-lib:int-add i ib)) + ((1 lda) (1 *))) + lda work ldwork))))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgehd2 n i ihi a lda tau work iinfo) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6)) + (setf iinfo var-7)) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum iws) 'double-float)) + end_label + (return (values nil nil nil nil nil nil nil nil info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgehrd + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + fixnum (array double-float (*)) + fixnum (array double-float (*)) + (array double-float (*)) fixnum + fixnum) + :return-values '(nil nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dgehd2 fortran-to-lisp::dlarfb + fortran-to-lisp::dgemm fortran-to-lisp::dlahrd + fortran-to-lisp::xerbla fortran-to-lisp::ilaenv)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgelq2 LAPACK} +\pagehead{dgelq2}{dgelq2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0)) + (declare (type (double-float 1.0 1.0) one)) + (defun dgelq2 (m n a lda tau work info) + (declare (type (array double-float (*)) work tau a) + (type fixnum info lda n m)) + (f2cl-lib:with-multi-array-data + ((a double-float a-%data% a-%offset%) + (tau double-float tau-%data% tau-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((aii 0.0) (i 0) (k 0)) + (declare (type (double-float) aii) (type fixnum i k)) + (setf info 0) + (cond + ((< m 0) + (setf info -1)) + ((< n 0) + (setf info -2)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info -4))) + (cond + ((/= info 0) + (xerbla "DGELQ2" (f2cl-lib:int-sub info)) + (go end_label))) + (setf k (min (the fixnum m) (the fixnum n))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i k) nil) + (tagbody + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlarfg (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1) + (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) + (f2cl-lib:array-slice a + double-float + (i + (min + (the fixnum + (f2cl-lib:int-add i 1)) + (the fixnum n))) + ((1 lda) (1 *))) + lda (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%)) + (declare (ignore var-0 var-2 var-3)) + (setf (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) + var-1) + (setf (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%) var-4)) + (cond + ((< i m) + (setf aii + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) + one) + (dlarf "Right" (f2cl-lib:int-sub m i) + (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1) + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) lda + (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%) + (f2cl-lib:array-slice a + double-float + ((+ i 1) i) + ((1 lda) (1 *))) + lda work) + (setf (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) + aii))))) + end_label + (return (values nil nil nil nil nil nil info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgelq2 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (array double-float (*)) fixnum + (array double-float (*)) (array double-float (*)) + fixnum) + :return-values '(nil nil nil nil nil nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlarf fortran-to-lisp::dlarfg + fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgelqf LAPACK} +\pagehead{dgelqf}{dgelqf} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun dgelqf (m n a lda tau work lwork info) + (declare (type (array double-float (*)) work tau a) + (type fixnum info lwork lda n m)) + (f2cl-lib:with-multi-array-data + ((a double-float a-%data% a-%offset%) + (tau double-float tau-%data% tau-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((i 0) (ib 0) (iinfo 0) (iws 0) (k 0) (ldwork 0) (lwkopt 0) (nb 0) + (nbmin 0) (nx 0) (lquery nil)) + (declare (type (member t nil) lquery) + (type fixnum nx nbmin nb lwkopt ldwork k iws iinfo + ib i)) + (setf info 0) + (setf nb (ilaenv 1 "DGELQF" " " m n -1 -1)) + (setf lwkopt (f2cl-lib:int-mul m nb)) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum lwkopt) 'double-float)) + (setf lquery (coerce (= lwork -1) '(member t nil))) + (cond + ((< m 0) + (setf info -1)) + ((< n 0) + (setf info -2)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info -4)) + ((and + (< lwork (max (the fixnum 1) (the fixnum m))) + (not lquery)) + (setf info -7))) + (cond + ((/= info 0) + (xerbla "DGELQF" (f2cl-lib:int-sub info)) + (go end_label)) + (lquery + (go end_label))) + (setf k (min (the fixnum m) (the fixnum n))) + (cond + ((= k 0) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum 1) 'double-float)) + (go end_label))) + (setf nbmin 2) + (setf nx 0) + (setf iws m) + (cond + ((and (> nb 1) (< nb k)) + (setf nx + (max (the fixnum 0) + (the fixnum + (ilaenv 3 "DGELQF" " " m n -1 -1)))) + (cond + ((< nx k) + (setf ldwork m) + (setf iws (f2cl-lib:int-mul ldwork nb)) + (cond + ((< lwork iws) + (setf nb (the fixnum (truncate lwork ldwork))) + (setf nbmin + (max (the fixnum 2) + (the fixnum + (ilaenv 2 "DGELQF" " " m n -1 -1)))))))))) + (cond + ((and (>= nb nbmin) (< nb k) (< nx k)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i nb)) + ((> i (f2cl-lib:int-add k (f2cl-lib:int-sub nx))) nil) + (tagbody + (setf ib + (min + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-sub k i) 1)) + (the fixnum nb))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6) + (dgelq2 ib (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1) + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) + lda (f2cl-lib:array-slice tau double-float (i) ((1 *))) work + iinfo) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5)) + (setf iinfo var-6)) + (cond + ((<= (f2cl-lib:int-add i ib) m) + (dlarft "Forward" "Rowwise" + (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1) ib + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) + lda (f2cl-lib:array-slice tau double-float (i) ((1 *))) work + ldwork) + (dlarfb "Right" "No transpose" "Forward" "Rowwise" + (f2cl-lib:int-add (f2cl-lib:int-sub m i ib) 1) + (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1) ib + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) + lda work ldwork + (f2cl-lib:array-slice a + double-float + ((+ i ib) i) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice work double-float ((+ ib 1)) ((1 *))) + ldwork)))))) + (t + (setf i 1))) + (if (<= i k) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6) + (dgelq2 (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) + (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1) + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) lda + (f2cl-lib:array-slice tau double-float (i) ((1 *))) work iinfo) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5)) + (setf iinfo var-6))) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum iws) 'double-float)) + end_label + (return (values nil nil nil nil nil nil nil info))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgelqf + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (array double-float (*)) fixnum + (array double-float (*)) (array double-float (*)) + fixnum + fixnum) + :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlarfb fortran-to-lisp::dlarft + fortran-to-lisp::dgelq2 fortran-to-lisp::xerbla + fortran-to-lisp::ilaenv)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgemm BLAS} +\pagehead{dgemm}{dgemm} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(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 dgemm (transa transb m n k alpha a lda b ldb$ beta c ldc) + (declare (type (array double-float (*)) c b a) + (type (double-float) beta alpha) + (type fixnum ldc ldb$ lda k n m) + (type (simple-array character (*)) transb transa)) + (f2cl-lib:with-multi-array-data + ((transa character transa-%data% transa-%offset%) + (transb character transb-%data% transb-%offset%) + (a double-float a-%data% a-%offset%) + (b double-float b-%data% b-%offset%) + (c double-float c-%data% c-%offset%)) + (prog ((temp 0.0) (i 0) (info 0) (j 0) (l 0) (ncola 0) (nrowa 0) + (nrowb 0) (nota nil) (notb nil)) + (declare (type (double-float) temp) + (type fixnum i info j l ncola nrowa nrowb) + (type (member t nil) nota notb)) + (setf nota (lsame transa "N")) + (setf notb (lsame transb "N")) + (cond + (nota + (setf nrowa m) + (setf ncola k)) + (t + (setf nrowa k) + (setf ncola m))) + (cond + (notb + (setf nrowb k)) + (t + (setf nrowb n))) + (setf info 0) + (cond + ((and (not nota) (not (lsame transa "C")) (not (lsame transa "T"))) + (setf info 1)) + ((and (not notb) (not (lsame transb "C")) (not (lsame transb "T"))) + (setf info 2)) + ((< m 0) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< k 0) + (setf info 5)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 8)) + ((< ldb$ + (max (the fixnum 1) (the fixnum nrowb))) + (setf info 10)) + ((< ldc (max (the fixnum 1) (the fixnum m))) + (setf info 13))) + (cond + ((/= info 0) + (xerbla "DGEMM " info) + (go end_label))) + (if (or (= m 0) (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) + (go end_label)) + (cond + ((= alpha zero) + (cond + ((= beta 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 c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))))) + (t + (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 c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))) + (go end_label))) + (cond + (notb + (cond + (nota + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (l j) ((1 ldb$) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (l j) + ((1 ldb$) (1 *)) + b-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%))))))))))))) + (t + (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 temp zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (l j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* alpha temp))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))))))) + (t + (cond + (nota + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%))))))))))))) + (t + (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 temp zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* alpha temp))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)))))))))))))) + end_label + (return + (values nil nil nil nil nil nil nil nil nil nil nil nil nil)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgemm fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + (simple-array character (1)) + fixnum fixnum + fixnum (double-float) + (array double-float (*)) fixnum + (array double-float (*)) fixnum + (double-float) (array double-float (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil + nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgemv BLAS} +\pagehead{dgemv}{dgemv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(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 dgemv (trans m n alpha a lda x incx beta y incy) + (declare (type (array double-float (*)) y x a) + (type (double-float) beta alpha) + (type fixnum incy incx lda n m) + (type (simple-array character (*)) trans)) + (f2cl-lib:with-multi-array-data + ((trans character trans-%data% trans-%offset%) + (a double-float a-%data% a-%offset%) + (x double-float x-%data% x-%offset%) + (y double-float y-%data% y-%offset%)) + (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (kx 0) (ky 0) + (lenx 0) (leny 0) (temp 0.0)) + (declare (type fixnum i info ix iy j jx jy kx ky lenx + leny) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 1)) + ((< m 0) + (setf info 2)) + ((< n 0) + (setf info 3)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info 6)) + ((= incx 0) + (setf info 8)) + ((= incy 0) + (setf info 11))) + (cond + ((/= info 0) + (xerbla "DGEMV " info) + (go end_label))) + (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one))) + (go end_label)) + (cond + ((lsame trans "N") + (setf lenx n) + (setf leny m)) + (t + (setf lenx m) + (setf leny n))) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub lenx 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub leny 1) + incy))))) + (cond + ((/= beta one) + (cond + ((= incy 1) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + zero)))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%)))))))) + (t + (setf iy ky) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + zero) + (setf iy (f2cl-lib:int-add iy incy))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%))) + (setf iy (f2cl-lib:int-add iy incy)))))))))) + (if (= alpha zero) (go end_label)) + (cond + ((lsame trans "N") + (setf jx kx) + (cond + ((= incy 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))))) + (setf jx (f2cl-lib:int-add jx incx))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf iy ky) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf iy (f2cl-lib:int-add iy incy)))))) + (setf jx (f2cl-lib:int-add jx incx))))))) + (t + (setf jy ky) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp))) + (setf jy (f2cl-lib:int-add jy incy))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp zero) + (setf ix kx) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp))) + (setf jy (f2cl-lib:int-add jy incy)))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil nil)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgemv fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum fixnum + (double-float) (array double-float (*)) + fixnum (array double-float (*)) + fixnum (double-float) + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgeqr2 LAPACK} +\pagehead{dgeqr2}{dgeqr2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0)) + (declare (type (double-float 1.0 1.0) one)) + (defun dgeqr2 (m n a lda tau work info) + (declare (type (array double-float (*)) work tau a) + (type fixnum info lda n m)) + (f2cl-lib:with-multi-array-data + ((a double-float a-%data% a-%offset%) + (tau double-float tau-%data% tau-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((aii 0.0) (i 0) (k 0)) + (declare (type (double-float) aii) (type fixnum i k)) + (setf info 0) + (cond + ((< m 0) + (setf info -1)) + ((< n 0) + (setf info -2)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info -4))) + (cond + ((/= info 0) + (xerbla "DGEQR2" (f2cl-lib:int-sub info)) + (go end_label))) + (setf k (min (the fixnum m) (the fixnum n))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i k) nil) + (tagbody + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlarfg (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) + (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) + (f2cl-lib:array-slice a + double-float + ((min (f2cl-lib:int-add i 1) m) i) + ((1 lda) (1 *))) + 1 (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%)) + (declare (ignore var-0 var-2 var-3)) + (setf (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) + var-1) + (setf (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%) var-4)) + (cond + ((< i n) + (setf aii + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) + one) + (dlarf "Left" (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) + (f2cl-lib:int-sub n i) + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) 1 + (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%) + (f2cl-lib:array-slice a + double-float + (i (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda work) + (setf (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) + aii))))) + end_label + (return (values nil nil nil nil nil nil info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgeqr2 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (array double-float (*)) fixnum + (array double-float (*)) (array double-float (*)) + fixnum) + :return-values '(nil nil nil nil nil nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlarf fortran-to-lisp::dlarfg + fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgeqrf LAPACK} +\pagehead{dgeqrf}{dgeqrf} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun dgeqrf (m n a lda tau work lwork info) + (declare (type (array double-float (*)) work tau a) + (type fixnum info lwork lda n m)) + (f2cl-lib:with-multi-array-data + ((a double-float a-%data% a-%offset%) + (tau double-float tau-%data% tau-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((i 0) (ib 0) (iinfo 0) (iws 0) (k 0) (ldwork 0) (lwkopt 0) (nb 0) + (nbmin 0) (nx 0) (lquery nil)) + (declare (type (member t nil) lquery) + (type fixnum nx nbmin nb lwkopt ldwork k iws iinfo + ib i)) + (setf info 0) + (setf nb (ilaenv 1 "DGEQRF" " " m n -1 -1)) + (setf lwkopt (f2cl-lib:int-mul n nb)) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum lwkopt) 'double-float)) + (setf lquery (coerce (= lwork -1) '(member t nil))) + (cond + ((< m 0) + (setf info -1)) + ((< n 0) + (setf info -2)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info -4)) + ((and + (< lwork (max (the fixnum 1) (the fixnum n))) + (not lquery)) + (setf info -7))) + (cond + ((/= info 0) + (xerbla "DGEQRF" (f2cl-lib:int-sub info)) + (go end_label)) + (lquery + (go end_label))) + (setf k (min (the fixnum m) (the fixnum n))) + (cond + ((= k 0) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum 1) 'double-float)) + (go end_label))) + (setf nbmin 2) + (setf nx 0) + (setf iws n) + (cond + ((and (> nb 1) (< nb k)) + (setf nx + (max (the fixnum 0) + (the fixnum + (ilaenv 3 "DGEQRF" " " m n -1 -1)))) + (cond + ((< nx k) + (setf ldwork n) + (setf iws (f2cl-lib:int-mul ldwork nb)) + (cond + ((< lwork iws) + (setf nb (the fixnum (truncate lwork ldwork))) + (setf nbmin + (max (the fixnum 2) + (the fixnum + (ilaenv 2 "DGEQRF" " " m n -1 -1)))))))))) + (cond + ((and (>= nb nbmin) (< nb k) (< nx k)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i nb)) + ((> i (f2cl-lib:int-add k (f2cl-lib:int-sub nx))) nil) + (tagbody + (setf ib + (min + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-sub k i) 1)) + (the fixnum nb))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6) + (dgeqr2 (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) ib + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) + lda (f2cl-lib:array-slice tau double-float (i) ((1 *))) work + iinfo) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5)) + (setf iinfo var-6)) + (cond + ((<= (f2cl-lib:int-add i ib) n) + (dlarft "Forward" "Columnwise" + (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) ib + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) + lda (f2cl-lib:array-slice tau double-float (i) ((1 *))) work + ldwork) + (dlarfb "Left" "Transpose" "Forward" "Columnwise" + (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) + (f2cl-lib:int-add (f2cl-lib:int-sub n i ib) 1) ib + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) + lda work ldwork + (f2cl-lib:array-slice a + double-float + (i (f2cl-lib:int-add i ib)) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice work double-float ((+ ib 1)) ((1 *))) + ldwork)))))) + (t + (setf i 1))) + (if (<= i k) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6) + (dgeqr2 (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) + (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1) + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) lda + (f2cl-lib:array-slice tau double-float (i) ((1 *))) work iinfo) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5)) + (setf iinfo var-6))) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum iws) 'double-float)) + end_label + (return (values nil nil nil nil nil nil nil info))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgeqrf + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (array double-float (*)) fixnum + (array double-float (*)) (array double-float (*)) + fixnum + fixnum) + :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlarfb fortran-to-lisp::dlarft + fortran-to-lisp::dgeqr2 fortran-to-lisp::xerbla + fortran-to-lisp::ilaenv)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dger BLAS} +\pagehead{dger}{dger} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dger (m n alpha x incx y incy a lda) + (declare (type (array double-float (*)) a y x) + (type (double-float) alpha) + (type fixnum lda incy incx n m)) + (f2cl-lib:with-multi-array-data + ((x double-float x-%data% x-%offset%) + (y double-float y-%data% y-%offset%) + (a double-float a-%data% a-%offset%)) + (prog ((i 0) (info 0) (ix 0) (j 0) (jy 0) (kx 0) (temp 0.0)) + (declare (type fixnum i info ix j jy kx) + (type (double-float) temp)) + (setf info 0) + (cond + ((< m 0) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 5)) + ((= incy 0) + (setf info 7)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "DGER " info) + (go end_label))) + (if (or (= m 0) (= n 0) (= alpha zero)) (go end_label)) + (cond + ((> incy 0) + (setf jy 1)) + (t + (setf jy + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incy))))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref y (jy) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%) + temp))))))) + (setf jy (f2cl-lib:int-add jy incy))))) + (t + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub m 1) + incx))))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref y (jy) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%))) + (setf ix kx) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp))) + (setf ix (f2cl-lib:int-add ix incx)))))) + (setf jy (f2cl-lib:int-add jy incy)))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dger fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (double-float) (array double-float (*)) + fixnum (array double-float (*)) + fixnum (array double-float (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgesdd LAPACK} +\pagehead{dgesdd}{dgesdd} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0) (one 1.0)) + (declare (type (double-float 0.0 0.0) zero) + (type (double-float 1.0 1.0) one)) + (defun dgesdd (jobz m n a lda s u ldu vt ldvt work lwork iwork info) + (declare (type (array fixnum (*)) iwork) + (type (array double-float (*)) work vt u s a) + (type fixnum info lwork ldvt ldu lda n m) + (type (simple-array character (*)) jobz)) + (f2cl-lib:with-multi-array-data + ((jobz character jobz-%data% jobz-%offset%) + (a double-float a-%data% a-%offset%) + (s double-float s-%data% s-%offset%) + (u double-float u-%data% u-%offset%) + (vt double-float vt-%data% vt-%offset%) + (work double-float work-%data% work-%offset%) + (iwork fixnum iwork-%data% iwork-%offset%)) + (prog ((dum (make-array 1 :element-type 'double-float)) + (idum (make-array 1 :element-type 'fixnum)) (anrm 0.0) + (bignum 0.0) (eps 0.0) (smlnum 0.0) (bdspac 0) (blk 0) (chunk 0) + (i 0) (ie 0) (ierr 0) (il 0) (ir 0) (iscl 0) (itau 0) (itaup 0) + (itauq 0) (iu 0) (ivt 0) (ldwkvt 0) (ldwrkl 0) (ldwrkr 0) + (ldwrku 0) (maxwrk 0) (minmn 0) (minwrk 0) (mnthr 0) (nwork 0) + (wrkbl 0) (lquery nil) (wntqa nil) (wntqas nil) (wntqn nil) + (wntqo nil) (wntqs nil)) + (declare (type (array double-float (1)) dum) + (type (array fixnum (1)) idum) + (type (double-float) anrm bignum eps smlnum) + (type fixnum bdspac blk chunk i ie ierr il ir + iscl itau itaup itauq iu ivt ldwkvt + ldwrkl ldwrkr ldwrku maxwrk minmn + minwrk mnthr nwork wrkbl) + (type (member t nil) lquery wntqa wntqas wntqn wntqo wntqs)) + (setf info 0) + (setf minmn (min (the fixnum m) (the fixnum n))) + (setf mnthr (f2cl-lib:int (/ (* minmn 11.0) 6.0))) + (setf wntqa (lsame jobz "A")) + (setf wntqs (lsame jobz "S")) + (setf wntqas (or wntqa wntqs)) + (setf wntqo (lsame jobz "O")) + (setf wntqn (lsame jobz "N")) + (setf minwrk 1) + (setf maxwrk 1) + (setf lquery (coerce (= lwork -1) '(member t nil))) + (cond + ((not (or wntqa wntqs wntqo wntqn)) + (setf info -1)) + ((< m 0) + (setf info -2)) + ((< n 0) + (setf info -3)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info -5)) + ((or (< ldu 1) (and wntqas (< ldu m)) (and wntqo (< m n) (< ldu m))) + (setf info -8)) + ((or (< ldvt 1) + (and wntqa (< ldvt n)) + (and wntqs (< ldvt minmn)) + (and wntqo (>= m n) (< ldvt n))) + (setf info -10))) + (cond + ((and (= info 0) (> m 0) (> n 0)) + (cond + ((>= m n) + (cond + (wntqn + (setf bdspac (f2cl-lib:int-mul 7 n))) + (t + (setf bdspac + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n n) + (f2cl-lib:int-mul 4 n))))) + (cond + ((>= m mnthr) + (cond + (wntqn + (setf wrkbl + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv 1 + "DGEQRF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul 2 + n + (ilaenv + 1 + "DGEBRD" + " " + n n + -1 + -1)))))) + (setf maxwrk + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add bdspac n)))) + (setf minwrk (f2cl-lib:int-add bdspac n))) + (wntqo + (setf wrkbl + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv 1 + "DGEQRF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGQR" + " " + m n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul 2 + n + (ilaenv + 1 + "DGEBRD" + " " + n n + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORMBR" + "QLN" + n n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORMBR" + "PRT" + n n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul 3 + n))))) + (setf maxwrk + (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul 2 n n))) + (setf minwrk + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul 2 n n) + (f2cl-lib:int-mul 3 n)))) + (wntqs + (setf wrkbl + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv 1 + "DGEQRF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGQR" + " " + m n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul 2 + n + (ilaenv + 1 + "DGEBRD" + " " + n n + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORMBR" + "QLN" + n n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORMBR" + "PRT" + n n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul 3 + n))))) + (setf maxwrk + (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul n n))) + (setf minwrk + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul n n) + (f2cl-lib:int-mul 3 n)))) + (wntqa + (setf wrkbl + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv 1 + "DGEQRF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add n + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORGQR" + " " + m m + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul 2 + n + (ilaenv + 1 + "DGEBRD" + " " + n n + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORMBR" + "QLN" + n n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORMBR" + "PRT" + n n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul 3 + n))))) + (setf maxwrk + (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul n n))) + (setf minwrk + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul n n) + (f2cl-lib:int-mul 3 n)))))) + (t + (setf wrkbl + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul + (f2cl-lib:int-add m n) + (ilaenv 1 "DGEBRD" " " m n -1 -1)))) + (cond + (wntqn + (setf maxwrk + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul 3 + n))))) + (setf minwrk + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (max (the fixnum m) + (the fixnum + bdspac))))) + (wntqo + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORMBR" + "QLN" + m n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORMBR" + "PRT" + n n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul 3 + n))))) + (setf maxwrk + (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul m n))) + (setf minwrk + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (max (the fixnum m) + (the fixnum + (f2cl-lib:int-add + (f2cl-lib:int-mul n n) + bdspac)))))) + (wntqs + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORMBR" + "QLN" + m n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORMBR" + "PRT" + n n + n + -1)))))) + (setf maxwrk + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul 3 + n))))) + (setf minwrk + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (max (the fixnum m) + (the fixnum + bdspac))))) + (wntqa + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORMBR" + "QLN" + m m + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORMBR" + "PRT" + n n + n + -1)))))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul 3 + n))))) + (setf minwrk + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (max (the fixnum m) + (the fixnum + bdspac))))))))) + (t + (cond + (wntqn + (setf bdspac (f2cl-lib:int-mul 7 m))) + (t + (setf bdspac + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m m) + (f2cl-lib:int-mul 4 m))))) + (cond + ((>= n mnthr) + (cond + (wntqn + (setf wrkbl + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv 1 + "DGELQF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul 2 + m + (ilaenv + 1 + "DGEBRD" + " " + m m + -1 + -1)))))) + (setf maxwrk + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add bdspac m)))) + (setf minwrk (f2cl-lib:int-add bdspac m))) + (wntqo + (setf wrkbl + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv 1 + "DGELQF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORGLQ" + " " + m n + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul 2 + m + (ilaenv + 1 + "DGEBRD" + " " + m m + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORMBR" + "QLN" + m m + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORMBR" + "PRT" + m m + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul 3 + m))))) + (setf maxwrk + (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul 2 m m))) + (setf minwrk + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul 2 m m) + (f2cl-lib:int-mul 3 m)))) + (wntqs + (setf wrkbl + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv 1 + "DGELQF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORGLQ" + " " + m n + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul 2 + m + (ilaenv + 1 + "DGEBRD" + " " + m m + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORMBR" + "QLN" + m m + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORMBR" + "PRT" + m m + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul 3 + m))))) + (setf maxwrk + (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul m m))) + (setf minwrk + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul m m) + (f2cl-lib:int-mul 3 m)))) + (wntqa + (setf wrkbl + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv 1 + "DGELQF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add m + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGLQ" + " " + n n + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul 2 + m + (ilaenv + 1 + "DGEBRD" + " " + m m + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORMBR" + "QLN" + m m + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORMBR" + "PRT" + m m + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul 3 + m))))) + (setf maxwrk + (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul m m))) + (setf minwrk + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul m m) + (f2cl-lib:int-mul 3 m)))))) + (t + (setf wrkbl + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul + (f2cl-lib:int-add m n) + (ilaenv 1 "DGEBRD" " " m n -1 -1)))) + (cond + (wntqn + (setf maxwrk + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul 3 + m))))) + (setf minwrk + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (max (the fixnum n) + (the fixnum + bdspac))))) + (wntqo + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORMBR" + "QLN" + m m + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORMBR" + "PRT" + m n + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul 3 + m))))) + (setf maxwrk + (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul m n))) + (setf minwrk + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (max (the fixnum n) + (the fixnum + (f2cl-lib:int-add + (f2cl-lib:int-mul m m) + bdspac)))))) + (wntqs + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORMBR" + "QLN" + m m + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORMBR" + "PRT" + m n + m + -1)))))) + (setf maxwrk + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul 3 + m))))) + (setf minwrk + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (max (the fixnum n) + (the fixnum + bdspac))))) + (wntqa + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORMBR" + "QLN" + m m + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORMBR" + "PRT" + n n + m + -1)))))) + (setf maxwrk + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add bdspac + (f2cl-lib:int-mul 3 + m))))) + (setf minwrk + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (max (the fixnum n) + (the fixnum + bdspac)))))))))) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum maxwrk) 'double-float)))) + (cond + ((and (< lwork minwrk) (not lquery)) + (setf info -12))) + (cond + ((/= info 0) + (xerbla "DGESDD" (f2cl-lib:int-sub info)) + (go end_label)) + (lquery + (go end_label))) + (cond + ((or (= m 0) (= n 0)) + (if (>= lwork 1) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) one)) + (go end_label))) + (setf eps (dlamch "P")) + (setf smlnum (/ (f2cl-lib:fsqrt (dlamch "S")) eps)) + (setf bignum (/ one smlnum)) + (setf anrm (dlange "M" m n a lda dum)) + (setf iscl 0) + (cond + ((and (> anrm zero) (< anrm smlnum)) + (setf iscl 1) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dlascl "G" 0 0 anrm smlnum m n a lda ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf ierr var-9))) + ((> anrm bignum) + (setf iscl 1) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dlascl "G" 0 0 anrm bignum m n a lda ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf ierr var-9)))) + (cond + ((>= m n) + (cond + ((>= m mnthr) + (cond + (wntqn + (setf itau 1) + (setf nwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6)) + (setf ierr var-7)) + (dlaset "L" (f2cl-lib:int-sub n 1) (f2cl-lib:int-sub n 1) zero + zero + (f2cl-lib:array-slice a double-float (2 1) ((1 lda) (1 *))) + lda) + (setf ie 1) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf nwork (f2cl-lib:int-add itaup n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10) + (dgebrd n n a lda s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf ierr var-10)) + (setf nwork (f2cl-lib:int-add ie n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dbdsdc "U" "N" n s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) dum + 1 dum 1 dum idum + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + iwork info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf info var-13))) + (wntqo + (setf ir 1) + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul lda n) + (f2cl-lib:int-mul n n) + (f2cl-lib:int-mul 3 n) + bdspac)) + (setf ldwrkr lda)) + (t + (setf ldwrkr + (the fixnum + (truncate (- lwork (* n n) (* 3 n) bdspac) + n))))) + (setf itau (f2cl-lib:int-add ir (f2cl-lib:int-mul ldwrkr n))) + (setf nwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6)) + (setf ierr var-7)) + (dlacpy "U" n n a lda + (f2cl-lib:array-slice work double-float (ir) ((1 *))) ldwrkr) + (dlaset "L" (f2cl-lib:int-sub n 1) (f2cl-lib:int-sub n 1) zero + zero + (f2cl-lib:array-slice work double-float ((+ ir 1)) ((1 *))) + ldwrkr) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dorgqr m n n a lda + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf nwork (f2cl-lib:int-add itaup n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10) + (dgebrd n n + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf ierr var-10)) + (setf iu nwork) + (setf nwork (f2cl-lib:int-add iu (f2cl-lib:int-mul n n))) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dbdsdc "U" "I" n s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work double-float (iu) ((1 *))) n + vt ldvt dum idum + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + iwork info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf info var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "Q" "L" "N" n n n + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (iu) ((1 *))) n + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "P" "R" "T" n n n + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + vt ldvt + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i ldwrkr)) + ((> i m) nil) + (tagbody + (setf chunk + (min + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1)) + (the fixnum ldwrkr))) + (dgemm "N" "N" chunk n n one + (f2cl-lib:array-slice a + double-float + (i 1) + ((1 lda) (1 *))) + lda (f2cl-lib:array-slice work double-float (iu) ((1 *))) + n zero + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr) + (dlacpy "F" chunk n + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr + (f2cl-lib:array-slice a + double-float + (i 1) + ((1 lda) (1 *))) + lda)))) + (wntqs + (setf ir 1) + (setf ldwrkr n) + (setf itau (f2cl-lib:int-add ir (f2cl-lib:int-mul ldwrkr n))) + (setf nwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6)) + (setf ierr var-7)) + (dlacpy "U" n n a lda + (f2cl-lib:array-slice work double-float (ir) ((1 *))) ldwrkr) + (dlaset "L" (f2cl-lib:int-sub n 1) (f2cl-lib:int-sub n 1) zero + zero + (f2cl-lib:array-slice work double-float ((+ ir 1)) ((1 *))) + ldwrkr) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dorgqr m n n a lda + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf nwork (f2cl-lib:int-add itaup n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10) + (dgebrd n n + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dbdsdc "U" "I" n s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) u + ldu vt ldvt dum idum + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + iwork info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf info var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "Q" "L" "N" n n n + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + u ldu + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "P" "R" "T" n n n + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + vt ldvt + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)) + (dlacpy "F" n n u ldu + (f2cl-lib:array-slice work double-float (ir) ((1 *))) ldwrkr) + (dgemm "N" "N" m n n one a lda + (f2cl-lib:array-slice work double-float (ir) ((1 *))) ldwrkr + zero u ldu)) + (wntqa + (setf iu 1) + (setf ldwrku n) + (setf itau (f2cl-lib:int-add iu (f2cl-lib:int-mul ldwrku n))) + (setf nwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6)) + (setf ierr var-7)) + (dlacpy "L" m n a lda u ldu) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dorgqr m m n u ldu + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7)) + (setf ierr var-8)) + (dlaset "L" (f2cl-lib:int-sub n 1) (f2cl-lib:int-sub n 1) zero + zero + (f2cl-lib:array-slice a double-float (2 1) ((1 lda) (1 *))) + lda) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf nwork (f2cl-lib:int-add itaup n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10) + (dgebrd n n a lda s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dbdsdc "U" "I" n s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work double-float (iu) ((1 *))) n + vt ldvt dum idum + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + iwork info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf info var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "Q" "L" "N" n n n a lda + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "P" "R" "T" n n n a lda + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + vt ldvt + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)) + (dgemm "N" "N" m n n one u ldu + (f2cl-lib:array-slice work double-float (iu) ((1 *))) ldwrku + zero a lda) + (dlacpy "F" m n a lda u ldu)))) + (t + (setf ie 1) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf nwork (f2cl-lib:int-add itaup n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10) + (dgebrd m n a lda s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf ierr var-10)) + (cond + (wntqn + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dbdsdc "U" "N" n s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) dum + 1 dum 1 dum idum + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + iwork info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf info var-13))) + (wntqo + (setf iu nwork) + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul m n) + (f2cl-lib:int-mul 3 n) + bdspac)) + (setf ldwrku m) + (setf nwork + (f2cl-lib:int-add iu (f2cl-lib:int-mul ldwrku n))) + (dlaset "F" m n zero zero + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku)) + (t + (setf ldwrku n) + (setf nwork + (f2cl-lib:int-add iu (f2cl-lib:int-mul ldwrku n))) + (setf ir nwork) + (setf ldwrkr + (the fixnum + (truncate (- lwork (* n n) (* 3 n)) n))))) + (setf nwork (f2cl-lib:int-add iu (f2cl-lib:int-mul ldwrku n))) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dbdsdc "U" "I" n s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku vt ldvt dum idum + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + iwork info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf info var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "P" "R" "T" n n n a lda + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + vt ldvt + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)) + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul m n) + (f2cl-lib:int-mul 3 n) + bdspac)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13) + (dormbr "Q" "L" "N" m n n a lda + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku + (f2cl-lib:array-slice work + double-float + (nwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12)) + (setf ierr var-13)) + (dlacpy "F" m n + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku a lda)) + (t + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" m n n a lda + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (nwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i ldwrkr)) + ((> i m) nil) + (tagbody + (setf chunk + (min + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-sub m i) + 1)) + (the fixnum ldwrkr))) + (dgemm "N" "N" chunk n n one + (f2cl-lib:array-slice a + double-float + (i 1) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku zero + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr) + (dlacpy "F" chunk n + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr + (f2cl-lib:array-slice a + double-float + (i 1) + ((1 lda) (1 *))) + lda)))))) + (wntqs + (dlaset "F" m n zero zero u ldu) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dbdsdc "U" "I" n s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) u + ldu vt ldvt dum idum + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + iwork info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf info var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "Q" "L" "N" m n n a lda + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + u ldu + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "P" "R" "T" n n n a lda + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + vt ldvt + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13))) + (wntqa + (dlaset "F" m m zero zero u ldu) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dbdsdc "U" "I" n s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) u + ldu vt ldvt dum idum + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + iwork info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf info var-13)) + (dlaset "F" (f2cl-lib:int-sub m n) (f2cl-lib:int-sub m n) zero + one + (f2cl-lib:array-slice u + double-float + ((+ n 1) (f2cl-lib:int-add n 1)) + ((1 ldu) (1 *))) + ldu) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "Q" "L" "N" m m n a lda + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + u ldu + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "P" "R" "T" n n m a lda + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + vt ldvt + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13))))))) + (t + (cond + ((>= n mnthr) + (cond + (wntqn + (setf itau 1) + (setf nwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6)) + (setf ierr var-7)) + (dlaset "U" (f2cl-lib:int-sub m 1) (f2cl-lib:int-sub m 1) zero + zero + (f2cl-lib:array-slice a double-float (1 2) ((1 lda) (1 *))) + lda) + (setf ie 1) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf nwork (f2cl-lib:int-add itaup m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10) + (dgebrd m m a lda s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf ierr var-10)) + (setf nwork (f2cl-lib:int-add ie m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dbdsdc "U" "N" m s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) dum + 1 dum 1 dum idum + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + iwork info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf info var-13))) + (wntqo + (setf ivt 1) + (setf il (f2cl-lib:int-add ivt (f2cl-lib:int-mul m m))) + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul m n) + (f2cl-lib:int-mul m m) + (f2cl-lib:int-mul 3 m) + bdspac)) + (setf ldwrkl m) + (setf chunk n)) + (t + (setf ldwrkl m) + (setf chunk + (the fixnum + (truncate (- lwork (* m m)) m))))) + (setf itau (f2cl-lib:int-add il (f2cl-lib:int-mul ldwrkl m))) + (setf nwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6)) + (setf ierr var-7)) + (dlacpy "L" m m a lda + (f2cl-lib:array-slice work double-float (il) ((1 *))) ldwrkl) + (dlaset "U" (f2cl-lib:int-sub m 1) (f2cl-lib:int-sub m 1) zero + zero + (f2cl-lib:array-slice work + double-float + ((+ il ldwrkl)) + ((1 *))) + ldwrkl) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dorglq m n m a lda + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf nwork (f2cl-lib:int-add itaup m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10) + (dgebrd m m + (f2cl-lib:array-slice work double-float (il) ((1 *))) + ldwrkl s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dbdsdc "U" "I" m s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) u + ldu + (f2cl-lib:array-slice work double-float (ivt) ((1 *))) m + dum idum + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + iwork info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf info var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "Q" "L" "N" m m m + (f2cl-lib:array-slice work double-float (il) ((1 *))) + ldwrkl + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + u ldu + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "P" "R" "T" m m m + (f2cl-lib:array-slice work double-float (il) ((1 *))) + ldwrkl + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (ivt) ((1 *))) m + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i chunk)) + ((> i n) nil) + (tagbody + (setf blk + (min + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1)) + (the fixnum chunk))) + (dgemm "N" "N" m blk m one + (f2cl-lib:array-slice work double-float (ivt) ((1 *))) m + (f2cl-lib:array-slice a + double-float + (1 i) + ((1 lda) (1 *))) + lda zero + (f2cl-lib:array-slice work double-float (il) ((1 *))) + ldwrkl) + (dlacpy "F" m blk + (f2cl-lib:array-slice work double-float (il) ((1 *))) + ldwrkl + (f2cl-lib:array-slice a + double-float + (1 i) + ((1 lda) (1 *))) + lda)))) + (wntqs + (setf il 1) + (setf ldwrkl m) + (setf itau (f2cl-lib:int-add il (f2cl-lib:int-mul ldwrkl m))) + (setf nwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6)) + (setf ierr var-7)) + (dlacpy "L" m m a lda + (f2cl-lib:array-slice work double-float (il) ((1 *))) ldwrkl) + (dlaset "U" (f2cl-lib:int-sub m 1) (f2cl-lib:int-sub m 1) zero + zero + (f2cl-lib:array-slice work + double-float + ((+ il ldwrkl)) + ((1 *))) + ldwrkl) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dorglq m n m a lda + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf nwork (f2cl-lib:int-add itaup m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10) + (dgebrd m m + (f2cl-lib:array-slice work double-float (il) ((1 *))) + ldwrkl s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dbdsdc "U" "I" m s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) u + ldu vt ldvt dum idum + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + iwork info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf info var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "Q" "L" "N" m m m + (f2cl-lib:array-slice work double-float (il) ((1 *))) + ldwrkl + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + u ldu + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "P" "R" "T" m m m + (f2cl-lib:array-slice work double-float (il) ((1 *))) + ldwrkl + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + vt ldvt + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)) + (dlacpy "F" m m vt ldvt + (f2cl-lib:array-slice work double-float (il) ((1 *))) ldwrkl) + (dgemm "N" "N" m n m one + (f2cl-lib:array-slice work double-float (il) ((1 *))) ldwrkl + a lda zero vt ldvt)) + (wntqa + (setf ivt 1) + (setf ldwkvt m) + (setf itau (f2cl-lib:int-add ivt (f2cl-lib:int-mul ldwkvt m))) + (setf nwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6)) + (setf ierr var-7)) + (dlacpy "U" m n a lda vt ldvt) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dorglq n n m vt ldvt + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7)) + (setf ierr var-8)) + (dlaset "U" (f2cl-lib:int-sub m 1) (f2cl-lib:int-sub m 1) zero + zero + (f2cl-lib:array-slice a double-float (1 2) ((1 lda) (1 *))) + lda) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf nwork (f2cl-lib:int-add itaup m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10) + (dgebrd m m a lda s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dbdsdc "U" "I" m s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) u + ldu + (f2cl-lib:array-slice work double-float (ivt) ((1 *))) + ldwkvt dum idum + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + iwork info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf info var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "Q" "L" "N" m m m a lda + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + u ldu + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "P" "R" "T" m m m a lda + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (ivt) ((1 *))) + ldwkvt + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)) + (dgemm "N" "N" m n m one + (f2cl-lib:array-slice work double-float (ivt) ((1 *))) ldwkvt + vt ldvt zero a lda) + (dlacpy "F" m n a lda vt ldvt)))) + (t + (setf ie 1) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf nwork (f2cl-lib:int-add itaup m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10) + (dgebrd m n a lda s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf ierr var-10)) + (cond + (wntqn + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dbdsdc "L" "N" m s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) dum + 1 dum 1 dum idum + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + iwork info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf info var-13))) + (wntqo + (setf ldwkvt m) + (setf ivt nwork) + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul m n) + (f2cl-lib:int-mul 3 m) + bdspac)) + (dlaset "F" m n zero zero + (f2cl-lib:array-slice work double-float (ivt) ((1 *))) + ldwkvt) + (setf nwork + (f2cl-lib:int-add ivt (f2cl-lib:int-mul ldwkvt n)))) + (t + (setf nwork + (f2cl-lib:int-add ivt (f2cl-lib:int-mul ldwkvt m))) + (setf il nwork) + (setf chunk + (the fixnum + (truncate (- lwork (* m m) (* 3 m)) m))))) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dbdsdc "L" "I" m s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) u + ldu + (f2cl-lib:array-slice work double-float (ivt) ((1 *))) + ldwkvt dum idum + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + iwork info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf info var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "Q" "L" "N" m m n a lda + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + u ldu + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)) + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul m n) + (f2cl-lib:int-mul 3 m) + bdspac)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13) + (dormbr "P" "R" "T" m n m a lda + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work double-float (ivt) ((1 *))) + ldwkvt + (f2cl-lib:array-slice work + double-float + (nwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12)) + (setf ierr var-13)) + (dlacpy "F" m n + (f2cl-lib:array-slice work double-float (ivt) ((1 *))) + ldwkvt a lda)) + (t + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" m n m a lda + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (nwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i chunk)) + ((> i n) nil) + (tagbody + (setf blk + (min + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-sub n i) + 1)) + (the fixnum chunk))) + (dgemm "N" "N" m blk m one + (f2cl-lib:array-slice work double-float (ivt) ((1 *))) + ldwkvt + (f2cl-lib:array-slice a + double-float + (1 i) + ((1 lda) (1 *))) + lda zero + (f2cl-lib:array-slice work double-float (il) ((1 *))) + m) + (dlacpy "F" m blk + (f2cl-lib:array-slice work double-float (il) ((1 *))) + m + (f2cl-lib:array-slice a + double-float + (1 i) + ((1 lda) (1 *))) + lda)))))) + (wntqs + (dlaset "F" m n zero zero vt ldvt) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dbdsdc "L" "I" m s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) u + ldu vt ldvt dum idum + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + iwork info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf info var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "Q" "L" "N" m m n a lda + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + u ldu + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "P" "R" "T" m n m a lda + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + vt ldvt + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13))) + (wntqa + (dlaset "F" n n zero zero vt ldvt) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dbdsdc "L" "I" m s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) u + ldu vt ldvt dum idum + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + iwork info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf info var-13)) + (dlaset "F" (f2cl-lib:int-sub n m) (f2cl-lib:int-sub n m) zero + one + (f2cl-lib:array-slice vt + double-float + ((+ m 1) (f2cl-lib:int-add m 1)) + ((1 ldvt) (1 *))) + ldvt) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "Q" "L" "N" m m n a lda + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + u ldu + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dormbr "P" "R" "T" n n m a lda + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + vt ldvt + (f2cl-lib:array-slice work double-float (nwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork nwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)))))))) + (cond + ((= iscl 1) + (if (> anrm bignum) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dlascl "G" 0 0 bignum anrm minmn 1 s minmn ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8)) + (setf ierr var-9))) + (if (< anrm smlnum) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dlascl "G" 0 0 smlnum anrm minmn 1 s minmn ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8)) + (setf ierr var-9))))) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (realpart maxwrk) 'double-float)) + end_label + (return + (values nil nil nil nil nil nil nil nil nil nil nil nil nil info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgesdd + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum fixnum + (array double-float (*)) fixnum + (array double-float (*)) (array double-float (*)) + fixnum (array double-float (*)) + fixnum (array double-float (*)) + fixnum + (array fixnum (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dorglq fortran-to-lisp::dgelqf + fortran-to-lisp::dorgbr fortran-to-lisp::dgemm + fortran-to-lisp::dormbr fortran-to-lisp::dorgqr + fortran-to-lisp::dlacpy fortran-to-lisp::dbdsdc + fortran-to-lisp::dgebrd fortran-to-lisp::dlaset + fortran-to-lisp::dgeqrf fortran-to-lisp::dlascl + fortran-to-lisp::dlange fortran-to-lisp::dlamch + fortran-to-lisp::xerbla fortran-to-lisp::ilaenv + fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgesvd LAPACK} +\pagehead{dgesvd}{dgesvd} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0) (one 1.0)) + (declare (type (double-float 0.0 0.0) zero) + (type (double-float 1.0 1.0) one)) + (defun dgesvd (jobu jobvt m n a lda s u ldu vt ldvt work lwork info) + (declare (type (array double-float (*)) work vt u s a) + (type fixnum info lwork ldvt ldu lda n m) + (type (simple-array character (*)) jobvt jobu)) + (f2cl-lib:with-multi-array-data + ((jobu character jobu-%data% jobu-%offset%) + (jobvt character jobvt-%data% jobvt-%offset%) + (a double-float a-%data% a-%offset%) + (s double-float s-%data% s-%offset%) + (u double-float u-%data% u-%offset%) + (vt double-float vt-%data% vt-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((dum (make-array 1 :element-type 'double-float)) (anrm 0.0) + (bignum 0.0) (eps 0.0) (smlnum 0.0) (bdspac 0) (blk 0) (chunk 0) + (i 0) (ie 0) (ierr 0) (ir 0) (iscl 0) (itau 0) (itaup 0) (itauq 0) + (iu 0) (iwork 0) (ldwrkr 0) (ldwrku 0) (maxwrk 0) (minmn 0) + (minwrk 0) (mnthr 0) (ncu 0) (ncvt 0) (nru 0) (nrvt 0) (wrkbl 0) + (lquery nil) (wntua nil) (wntuas nil) (wntun nil) (wntuo nil) + (wntus nil) (wntva nil) (wntvas nil) (wntvn nil) (wntvo nil) + (wntvs nil)) + (declare (type (array double-float (1)) dum) + (type (double-float) anrm bignum eps smlnum) + (type fixnum bdspac blk chunk i ie ierr ir iscl + itau itaup itauq iu iwork ldwrkr + ldwrku maxwrk minmn minwrk mnthr ncu + ncvt nru nrvt wrkbl) + (type (member t nil) lquery wntua wntuas wntun wntuo wntus + wntva wntvas wntvn wntvo wntvs)) + (setf info 0) + (setf minmn (min (the fixnum m) (the fixnum n))) + (setf mnthr (ilaenv 6 "DGESVD" (f2cl-lib:f2cl-// jobu jobvt) m n 0 0)) + (setf wntua (lsame jobu "A")) + (setf wntus (lsame jobu "S")) + (setf wntuas (or wntua wntus)) + (setf wntuo (lsame jobu "O")) + (setf wntun (lsame jobu "N")) + (setf wntva (lsame jobvt "A")) + (setf wntvs (lsame jobvt "S")) + (setf wntvas (or wntva wntvs)) + (setf wntvo (lsame jobvt "O")) + (setf wntvn (lsame jobvt "N")) + (setf minwrk 1) + (setf lquery (coerce (= lwork -1) '(member t nil))) + (cond + ((not (or wntua wntus wntuo wntun)) + (setf info -1)) + ((or (not (or wntva wntvs wntvo wntvn)) (and wntvo wntuo)) + (setf info -2)) + ((< m 0) + (setf info -3)) + ((< n 0) + (setf info -4)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info -6)) + ((or (< ldu 1) (and wntuas (< ldu m))) + (setf info -9)) + ((or (< ldvt 1) (and wntva (< ldvt n)) (and wntvs (< ldvt minmn))) + (setf info -11))) + (cond + ((and (= info 0) (or (>= lwork 1) lquery) (> m 0) (> n 0)) + (cond + ((>= m n) + (setf bdspac (f2cl-lib:int-mul 5 n)) + (cond + ((>= m mnthr) + (cond + (wntun + (setf maxwrk + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv 1 + "DGEQRF" " " m + n -1 -1)))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul 2 + n + (ilaenv + 1 + "DGEBRD" + " " + n n + -1 + -1)))))) + (if (or wntvo wntvas) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum + (f2cl-lib:int-add + (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + (ilaenv 1 "DORGBR" "P" n n n + -1))))))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum bdspac))) + (setf minwrk + (max (the fixnum (f2cl-lib:int-mul 4 n)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk)))) + ((and wntuo wntvn) + (setf wrkbl + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv 1 + "DGEQRF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGQR" + " " + m n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul 2 + n + (ilaenv + 1 + "DGEBRD" + " " + n n + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGBR" + "Q" + n n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum bdspac))) + (setf maxwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul n n) + wrkbl)) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul n n) + (f2cl-lib:int-mul m n) + n)))) + (setf minwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) m)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk)))) + ((and wntuo wntvas) + (setf wrkbl + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv 1 + "DGEQRF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGQR" + " " + m n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul 2 + n + (ilaenv + 1 + "DGEBRD" + " " + n n + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGBR" + "Q" + n n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + (ilaenv 1 "DORGBR" "P" + n n n -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum bdspac))) + (setf maxwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul n n) + wrkbl)) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul n n) + (f2cl-lib:int-mul m n) + n)))) + (setf minwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) m)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk)))) + ((and wntus wntvn) + (setf wrkbl + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv 1 + "DGEQRF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGQR" + " " + m n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul 2 + n + (ilaenv + 1 + "DGEBRD" + " " + n n + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGBR" + "Q" + n n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum bdspac))) + (setf maxwrk + (f2cl-lib:int-add (f2cl-lib:int-mul n n) wrkbl)) + (setf minwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) m)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk)))) + ((and wntus wntvo) + (setf wrkbl + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv 1 + "DGEQRF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGQR" + " " + m n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul 2 + n + (ilaenv + 1 + "DGEBRD" + " " + n n + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGBR" + "Q" + n n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + (ilaenv 1 "DORGBR" "P" + n n n -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum bdspac))) + (setf maxwrk + (f2cl-lib:int-add (f2cl-lib:int-mul 2 n n) wrkbl)) + (setf minwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) m)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk)))) + ((and wntus wntvas) + (setf wrkbl + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv 1 + "DGEQRF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGQR" + " " + m n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul 2 + n + (ilaenv + 1 + "DGEBRD" + " " + n n + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGBR" + "Q" + n n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + (ilaenv 1 "DORGBR" "P" + n n n -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum bdspac))) + (setf maxwrk + (f2cl-lib:int-add (f2cl-lib:int-mul n n) wrkbl)) + (setf minwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) m)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk)))) + ((and wntua wntvn) + (setf wrkbl + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv 1 + "DGEQRF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add n + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORGQR" + " " + m m + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul 2 + n + (ilaenv + 1 + "DGEBRD" + " " + n n + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGBR" + "Q" + n n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum bdspac))) + (setf maxwrk + (f2cl-lib:int-add (f2cl-lib:int-mul n n) wrkbl)) + (setf minwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) m)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk)))) + ((and wntua wntvo) + (setf wrkbl + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv 1 + "DGEQRF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add n + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORGQR" + " " + m m + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul 2 + n + (ilaenv + 1 + "DGEBRD" + " " + n n + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGBR" + "Q" + n n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + (ilaenv 1 "DORGBR" "P" + n n n -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum bdspac))) + (setf maxwrk + (f2cl-lib:int-add (f2cl-lib:int-mul 2 n n) wrkbl)) + (setf minwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) m)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk)))) + ((and wntua wntvas) + (setf wrkbl + (f2cl-lib:int-add n + (f2cl-lib:int-mul n + (ilaenv 1 + "DGEQRF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add n + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORGQR" + " " + m m + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul 2 + n + (ilaenv + 1 + "DGEBRD" + " " + n n + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGBR" + "Q" + n n + n + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + (ilaenv 1 "DORGBR" "P" + n n n -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum bdspac))) + (setf maxwrk + (f2cl-lib:int-add (f2cl-lib:int-mul n n) wrkbl)) + (setf minwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) m)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk)))))) + (t + (setf maxwrk + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul + (f2cl-lib:int-add m n) + (ilaenv 1 "DGEBRD" " " m n -1 -1)))) + (if (or wntus wntuo) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGBR" + "Q" + m n + n + -1))))))) + (if wntua + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORGBR" + "Q" + m m + n + -1))))))) + (if (not wntvn) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) + (f2cl-lib:int-mul + (f2cl-lib:int-sub n + 1) + (ilaenv 1 "DORGBR" + "P" n n n -1))))))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum bdspac))) + (setf minwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 n) m)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk)))))) + (t + (setf bdspac (f2cl-lib:int-mul 5 m)) + (cond + ((>= n mnthr) + (cond + (wntvn + (setf maxwrk + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv 1 + "DGELQF" " " m + n -1 -1)))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul 2 + m + (ilaenv + 1 + "DGEBRD" + " " + m m + -1 + -1)))))) + (if (or wntuo wntuas) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum + (f2cl-lib:int-add + (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul m + (ilaenv 1 "DORGBR" + "Q" m m m + -1))))))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum bdspac))) + (setf minwrk + (max (the fixnum (f2cl-lib:int-mul 4 m)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk)))) + ((and wntvo wntun) + (setf wrkbl + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv 1 + "DGELQF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORGLQ" + " " + m n + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul 2 + m + (ilaenv + 1 + "DGEBRD" + " " + m m + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul + (f2cl-lib:int-sub m 1) + (ilaenv 1 "DORGBR" "P" + m m m -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum bdspac))) + (setf maxwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul m m) + wrkbl)) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul m m) + (f2cl-lib:int-mul m n) + m)))) + (setf minwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) n)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk)))) + ((and wntvo wntuas) + (setf wrkbl + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv 1 + "DGELQF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORGLQ" + " " + m n + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul 2 + m + (ilaenv + 1 + "DGEBRD" + " " + m m + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul + (f2cl-lib:int-sub m 1) + (ilaenv 1 "DORGBR" "P" + m m m -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORGBR" + "Q" + m m + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum bdspac))) + (setf maxwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul m m) + wrkbl)) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul m m) + (f2cl-lib:int-mul m n) + m)))) + (setf minwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) n)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk)))) + ((and wntvs wntun) + (setf wrkbl + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv 1 + "DGELQF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORGLQ" + " " + m n + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul 2 + m + (ilaenv + 1 + "DGEBRD" + " " + m m + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul + (f2cl-lib:int-sub m 1) + (ilaenv 1 "DORGBR" "P" + m m m -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum bdspac))) + (setf maxwrk + (f2cl-lib:int-add (f2cl-lib:int-mul m m) wrkbl)) + (setf minwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) n)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk)))) + ((and wntvs wntuo) + (setf wrkbl + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv 1 + "DGELQF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORGLQ" + " " + m n + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul 2 + m + (ilaenv + 1 + "DGEBRD" + " " + m m + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul + (f2cl-lib:int-sub m 1) + (ilaenv 1 "DORGBR" "P" + m m m -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORGBR" + "Q" + m m + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum bdspac))) + (setf maxwrk + (f2cl-lib:int-add (f2cl-lib:int-mul 2 m m) wrkbl)) + (setf minwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) n)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk)))) + ((and wntvs wntuas) + (setf wrkbl + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv 1 + "DGELQF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORGLQ" + " " + m n + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul 2 + m + (ilaenv + 1 + "DGEBRD" + " " + m m + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul + (f2cl-lib:int-sub m 1) + (ilaenv 1 "DORGBR" "P" + m m m -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORGBR" + "Q" + m m + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum bdspac))) + (setf maxwrk + (f2cl-lib:int-add (f2cl-lib:int-mul m m) wrkbl)) + (setf minwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) n)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk)))) + ((and wntva wntun) + (setf wrkbl + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv 1 + "DGELQF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add m + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGLQ" + " " + n n + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul 2 + m + (ilaenv + 1 + "DGEBRD" + " " + m m + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul + (f2cl-lib:int-sub m 1) + (ilaenv 1 "DORGBR" "P" + m m m -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum bdspac))) + (setf maxwrk + (f2cl-lib:int-add (f2cl-lib:int-mul m m) wrkbl)) + (setf minwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) n)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk)))) + ((and wntva wntuo) + (setf wrkbl + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv 1 + "DGELQF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add m + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGLQ" + " " + n n + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul 2 + m + (ilaenv + 1 + "DGEBRD" + " " + m m + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul + (f2cl-lib:int-sub m 1) + (ilaenv 1 "DORGBR" "P" + m m m -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORGBR" + "Q" + m m + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum bdspac))) + (setf maxwrk + (f2cl-lib:int-add (f2cl-lib:int-mul 2 m m) wrkbl)) + (setf minwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) n)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk)))) + ((and wntva wntuas) + (setf wrkbl + (f2cl-lib:int-add m + (f2cl-lib:int-mul m + (ilaenv 1 + "DGELQF" " " m + n -1 -1)))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add m + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGLQ" + " " + n n + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul 2 + m + (ilaenv + 1 + "DGEBRD" + " " + m m + -1 + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul + (f2cl-lib:int-sub m 1) + (ilaenv 1 "DORGBR" "P" + m m m -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORGBR" + "Q" + m m + m + -1)))))) + (setf wrkbl + (max (the fixnum wrkbl) + (the fixnum bdspac))) + (setf maxwrk + (f2cl-lib:int-add (f2cl-lib:int-mul m m) wrkbl)) + (setf minwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) n)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk)))))) + (t + (setf maxwrk + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul + (f2cl-lib:int-add m n) + (ilaenv 1 "DGEBRD" " " m n -1 -1)))) + (if (or wntvs wntvo) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul m + (ilaenv + 1 + "DORGBR" + "P" + m n + m + -1))))))) + (if wntva + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul n + (ilaenv + 1 + "DORGBR" + "P" + n n + m + -1))))))) + (if (not wntun) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) + (f2cl-lib:int-mul + (f2cl-lib:int-sub m + 1) + (ilaenv 1 "DORGBR" + "Q" m m m -1))))))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum bdspac))) + (setf minwrk + (max + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-mul 3 m) n)) + (the fixnum bdspac))) + (setf maxwrk + (max (the fixnum maxwrk) + (the fixnum minwrk))))))) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum maxwrk) 'double-float)))) + (cond + ((and (< lwork minwrk) (not lquery)) + (setf info -13))) + (cond + ((/= info 0) + (xerbla "DGESVD" (f2cl-lib:int-sub info)) + (go end_label)) + (lquery + (go end_label))) + (cond + ((or (= m 0) (= n 0)) + (if (>= lwork 1) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) one)) + (go end_label))) + (setf eps (dlamch "P")) + (setf smlnum (/ (f2cl-lib:fsqrt (dlamch "S")) eps)) + (setf bignum (/ one smlnum)) + (setf anrm (dlange "M" m n a lda dum)) + (setf iscl 0) + (cond + ((and (> anrm zero) (< anrm smlnum)) + (setf iscl 1) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dlascl "G" 0 0 anrm smlnum m n a lda ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf ierr var-9))) + ((> anrm bignum) + (setf iscl 1) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dlascl "G" 0 0 anrm bignum m n a lda ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf ierr var-9)))) + (cond + ((>= m n) + (cond + ((>= m mnthr) + (cond + (wntun + (setf itau 1) + (setf iwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6)) + (setf ierr var-7)) + (dlaset "L" (f2cl-lib:int-sub n 1) (f2cl-lib:int-sub n 1) zero + zero + (f2cl-lib:array-slice a double-float (2 1) ((1 lda) (1 *))) + lda) + (setf ie 1) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf iwork (f2cl-lib:int-add itaup n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10) + (dgebrd n n a lda s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf ierr var-10)) + (setf ncvt 0) + (cond + ((or wntvo wntvas) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" n n n a lda + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf ncvt n))) + (setf iwork (f2cl-lib:int-add ie n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n ncvt 0 0 s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) a + lda dum 1 dum 1 + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12 + var-13)) + (setf info var-14)) + (if wntvas (dlacpy "F" n n a lda vt ldvt))) + ((and wntuo wntvn) + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul n n) + (max + (the fixnum + (f2cl-lib:int-mul 4 n)) + (the fixnum bdspac)))) + (setf ir 1) + (cond + ((>= lwork + (f2cl-lib:int-add + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add + (f2cl-lib:int-mul lda n) + n))) + (f2cl-lib:int-mul lda n))) + (setf ldwrku lda) + (setf ldwrkr lda)) + ((>= lwork + (f2cl-lib:int-add + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add + (f2cl-lib:int-mul lda n) + n))) + (f2cl-lib:int-mul n n))) + (setf ldwrku lda) + (setf ldwrkr n)) + (t + (setf ldwrku + (the fixnum + (truncate (- lwork (* n n) n) n))) + (setf ldwrkr n))) + (setf itau + (f2cl-lib:int-add ir (f2cl-lib:int-mul ldwrkr n))) + (setf iwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "U" n n a lda + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr) + (dlaset "L" (f2cl-lib:int-sub n 1) (f2cl-lib:int-sub n 1) + zero zero + (f2cl-lib:array-slice work + double-float + ((+ ir 1)) + ((1 *))) + ldwrkr) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorgqr m n n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf iwork (f2cl-lib:int-add itaup n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd n n + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" n n n + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n 0 n 0 s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + dum 1 + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14)) + (setf iu (f2cl-lib:int-add ie n)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i ldwrku)) + ((> i m) nil) + (tagbody + (setf chunk + (min + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-sub m i) + 1)) + (the fixnum ldwrku))) + (dgemm "N" "N" chunk n n one + (f2cl-lib:array-slice a + double-float + (i 1) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr zero + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku) + (dlacpy "F" chunk n + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku + (f2cl-lib:array-slice a + double-float + (i 1) + ((1 lda) (1 *))) + lda)))) + (t + (setf ie 1) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf iwork (f2cl-lib:int-add itaup n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd m n a lda s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" m n n a lda + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n 0 m 0 s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + dum 1 a lda dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14))))) + ((and wntuo wntvas) + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul n n) + (max + (the fixnum + (f2cl-lib:int-mul 4 n)) + (the fixnum bdspac)))) + (setf ir 1) + (cond + ((>= lwork + (f2cl-lib:int-add + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add + (f2cl-lib:int-mul lda n) + n))) + (f2cl-lib:int-mul lda n))) + (setf ldwrku lda) + (setf ldwrkr lda)) + ((>= lwork + (f2cl-lib:int-add + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add + (f2cl-lib:int-mul lda n) + n))) + (f2cl-lib:int-mul n n))) + (setf ldwrku lda) + (setf ldwrkr n)) + (t + (setf ldwrku + (the fixnum + (truncate (- lwork (* n n) n) n))) + (setf ldwrkr n))) + (setf itau + (f2cl-lib:int-add ir (f2cl-lib:int-mul ldwrkr n))) + (setf iwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "U" n n a lda vt ldvt) + (dlaset "L" (f2cl-lib:int-sub n 1) (f2cl-lib:int-sub n 1) + zero zero + (f2cl-lib:array-slice vt + double-float + (2 1) + ((1 ldvt) (1 *))) + ldvt) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorgqr m n n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf iwork (f2cl-lib:int-add itaup n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd n n vt ldvt s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (dlacpy "L" n n vt ldvt + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" n n n + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" n n n vt ldvt + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n n n 0 s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + vt ldvt + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14)) + (setf iu (f2cl-lib:int-add ie n)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i ldwrku)) + ((> i m) nil) + (tagbody + (setf chunk + (min + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-sub m i) + 1)) + (the fixnum ldwrku))) + (dgemm "N" "N" chunk n n one + (f2cl-lib:array-slice a + double-float + (i 1) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr zero + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku) + (dlacpy "F" chunk n + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku + (f2cl-lib:array-slice a + double-float + (i 1) + ((1 lda) (1 *))) + lda)))) + (t + (setf itau 1) + (setf iwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "U" n n a lda vt ldvt) + (dlaset "L" (f2cl-lib:int-sub n 1) (f2cl-lib:int-sub n 1) + zero zero + (f2cl-lib:array-slice vt + double-float + (2 1) + ((1 ldvt) (1 *))) + ldvt) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorgqr m n n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf iwork (f2cl-lib:int-add itaup n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd n n vt ldvt s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13) + (dormbr "Q" "R" "N" m n n vt ldvt + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + a lda + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" n n n vt ldvt + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n n m 0 s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + vt ldvt a lda dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14))))) + (wntus + (cond + (wntvn + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul n n) + (max + (the fixnum + (f2cl-lib:int-mul 4 n)) + (the fixnum bdspac)))) + (setf ir 1) + (cond + ((>= lwork + (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda n))) + (setf ldwrkr lda)) + (t + (setf ldwrkr n))) + (setf itau + (f2cl-lib:int-add ir + (f2cl-lib:int-mul ldwrkr n))) + (setf iwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "U" n n a lda + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr) + (dlaset "L" (f2cl-lib:int-sub n 1) + (f2cl-lib:int-sub n 1) zero zero + (f2cl-lib:array-slice work + double-float + ((+ ir 1)) + ((1 *))) + ldwrkr) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorgqr m n n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf iwork (f2cl-lib:int-add itaup n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd n n + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" n n n + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n 0 n 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + dum 1 + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14)) + (dgemm "N" "N" m n n one a lda + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr zero u ldu)) + (t + (setf itau 1) + (setf iwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "L" m n a lda u ldu) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorgqr m n n u ldu + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf iwork (f2cl-lib:int-add itaup n)) + (dlaset "L" (f2cl-lib:int-sub n 1) + (f2cl-lib:int-sub n 1) zero zero + (f2cl-lib:array-slice a + double-float + (2 1) + ((1 lda) (1 *))) + lda) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd n n a lda s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13) + (dormbr "Q" "R" "N" m n n a lda + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + u ldu + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12)) + (setf ierr var-13)) + (setf iwork (f2cl-lib:int-add ie n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n 0 m 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + dum 1 u ldu dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14))))) + (wntvo + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul 2 n n) + (max + (the fixnum + (f2cl-lib:int-mul 4 n)) + (the fixnum bdspac)))) + (setf iu 1) + (cond + ((>= lwork + (f2cl-lib:int-add wrkbl + (f2cl-lib:int-mul 2 lda n))) + (setf ldwrku lda) + (setf ir + (f2cl-lib:int-add iu + (f2cl-lib:int-mul ldwrku + n))) + (setf ldwrkr lda)) + ((>= lwork + (f2cl-lib:int-add wrkbl + (f2cl-lib:int-mul + (f2cl-lib:int-add lda n) + n))) + (setf ldwrku lda) + (setf ir + (f2cl-lib:int-add iu + (f2cl-lib:int-mul ldwrku + n))) + (setf ldwrkr n)) + (t + (setf ldwrku n) + (setf ir + (f2cl-lib:int-add iu + (f2cl-lib:int-mul ldwrku + n))) + (setf ldwrkr n))) + (setf itau + (f2cl-lib:int-add ir + (f2cl-lib:int-mul ldwrkr n))) + (setf iwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "U" n n a lda + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku) + (dlaset "L" (f2cl-lib:int-sub n 1) + (f2cl-lib:int-sub n 1) zero zero + (f2cl-lib:array-slice work + double-float + ((+ iu 1)) + ((1 *))) + ldwrku) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorgqr m n n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf iwork (f2cl-lib:int-add itaup n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd n n + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (dlacpy "U" n n + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" n n n + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" n n n + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n n n 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14)) + (dgemm "N" "N" m n n one a lda + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku zero u ldu) + (dlacpy "F" n n + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr a lda)) + (t + (setf itau 1) + (setf iwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "L" m n a lda u ldu) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorgqr m n n u ldu + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf iwork (f2cl-lib:int-add itaup n)) + (dlaset "L" (f2cl-lib:int-sub n 1) + (f2cl-lib:int-sub n 1) zero zero + (f2cl-lib:array-slice a + double-float + (2 1) + ((1 lda) (1 *))) + lda) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd n n a lda s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13) + (dormbr "Q" "R" "N" m n n a lda + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + u ldu + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" n n n a lda + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n n m 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + a lda u ldu dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14))))) + (wntvas + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul n n) + (max + (the fixnum + (f2cl-lib:int-mul 4 n)) + (the fixnum bdspac)))) + (setf iu 1) + (cond + ((>= lwork + (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda n))) + (setf ldwrku lda)) + (t + (setf ldwrku n))) + (setf itau + (f2cl-lib:int-add iu + (f2cl-lib:int-mul ldwrku n))) + (setf iwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "U" n n a lda + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku) + (dlaset "L" (f2cl-lib:int-sub n 1) + (f2cl-lib:int-sub n 1) zero zero + (f2cl-lib:array-slice work + double-float + ((+ iu 1)) + ((1 *))) + ldwrku) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorgqr m n n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf iwork (f2cl-lib:int-add itaup n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd n n + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (dlacpy "U" n n + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku vt ldvt) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" n n n + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" n n n vt ldvt + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n n n 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + vt ldvt + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14)) + (dgemm "N" "N" m n n one a lda + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku zero u ldu)) + (t + (setf itau 1) + (setf iwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "L" m n a lda u ldu) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorgqr m n n u ldu + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (dlacpy "U" n n a lda vt ldvt) + (dlaset "L" (f2cl-lib:int-sub n 1) + (f2cl-lib:int-sub n 1) zero zero + (f2cl-lib:array-slice vt + double-float + (2 1) + ((1 ldvt) (1 *))) + ldvt) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf iwork (f2cl-lib:int-add itaup n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd n n vt ldvt s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13) + (dormbr "Q" "R" "N" m n n vt ldvt + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + u ldu + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" n n n vt ldvt + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n n m 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + vt ldvt u ldu dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14))))))) + (wntua + (cond + (wntvn + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul n n) + (max + (the fixnum + (f2cl-lib:int-add n m)) + (the fixnum + (f2cl-lib:int-mul 4 n)) + (the fixnum bdspac)))) + (setf ir 1) + (cond + ((>= lwork + (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda n))) + (setf ldwrkr lda)) + (t + (setf ldwrkr n))) + (setf itau + (f2cl-lib:int-add ir + (f2cl-lib:int-mul ldwrkr n))) + (setf iwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "L" m n a lda u ldu) + (dlacpy "U" n n a lda + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr) + (dlaset "L" (f2cl-lib:int-sub n 1) + (f2cl-lib:int-sub n 1) zero zero + (f2cl-lib:array-slice work + double-float + ((+ ir 1)) + ((1 *))) + ldwrkr) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorgqr m m n u ldu + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf iwork (f2cl-lib:int-add itaup n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd n n + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" n n n + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n 0 n 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + dum 1 + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14)) + (dgemm "N" "N" m n n one u ldu + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr zero a lda) + (dlacpy "F" m n a lda u ldu)) + (t + (setf itau 1) + (setf iwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "L" m n a lda u ldu) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorgqr m m n u ldu + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf iwork (f2cl-lib:int-add itaup n)) + (dlaset "L" (f2cl-lib:int-sub n 1) + (f2cl-lib:int-sub n 1) zero zero + (f2cl-lib:array-slice a + double-float + (2 1) + ((1 lda) (1 *))) + lda) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd n n a lda s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13) + (dormbr "Q" "R" "N" m n n a lda + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + u ldu + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12)) + (setf ierr var-13)) + (setf iwork (f2cl-lib:int-add ie n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n 0 m 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + dum 1 u ldu dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14))))) + (wntvo + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul 2 n n) + (max + (the fixnum + (f2cl-lib:int-add n m)) + (the fixnum + (f2cl-lib:int-mul 4 n)) + (the fixnum bdspac)))) + (setf iu 1) + (cond + ((>= lwork + (f2cl-lib:int-add wrkbl + (f2cl-lib:int-mul 2 lda n))) + (setf ldwrku lda) + (setf ir + (f2cl-lib:int-add iu + (f2cl-lib:int-mul ldwrku + n))) + (setf ldwrkr lda)) + ((>= lwork + (f2cl-lib:int-add wrkbl + (f2cl-lib:int-mul + (f2cl-lib:int-add lda n) + n))) + (setf ldwrku lda) + (setf ir + (f2cl-lib:int-add iu + (f2cl-lib:int-mul ldwrku + n))) + (setf ldwrkr n)) + (t + (setf ldwrku n) + (setf ir + (f2cl-lib:int-add iu + (f2cl-lib:int-mul ldwrku + n))) + (setf ldwrkr n))) + (setf itau + (f2cl-lib:int-add ir + (f2cl-lib:int-mul ldwrkr n))) + (setf iwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "L" m n a lda u ldu) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorgqr m m n u ldu + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (dlacpy "U" n n a lda + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku) + (dlaset "L" (f2cl-lib:int-sub n 1) + (f2cl-lib:int-sub n 1) zero zero + (f2cl-lib:array-slice work + double-float + ((+ iu 1)) + ((1 *))) + ldwrku) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf iwork (f2cl-lib:int-add itaup n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd n n + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (dlacpy "U" n n + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" n n n + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" n n n + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n n n 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14)) + (dgemm "N" "N" m n n one u ldu + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku zero a lda) + (dlacpy "F" m n a lda u ldu) + (dlacpy "F" n n + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr a lda)) + (t + (setf itau 1) + (setf iwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "L" m n a lda u ldu) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorgqr m m n u ldu + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf iwork (f2cl-lib:int-add itaup n)) + (dlaset "L" (f2cl-lib:int-sub n 1) + (f2cl-lib:int-sub n 1) zero zero + (f2cl-lib:array-slice a + double-float + (2 1) + ((1 lda) (1 *))) + lda) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd n n a lda s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13) + (dormbr "Q" "R" "N" m n n a lda + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + u ldu + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" n n n a lda + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n n m 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + a lda u ldu dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14))))) + (wntvas + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul n n) + (max + (the fixnum + (f2cl-lib:int-add n m)) + (the fixnum + (f2cl-lib:int-mul 4 n)) + (the fixnum bdspac)))) + (setf iu 1) + (cond + ((>= lwork + (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda n))) + (setf ldwrku lda)) + (t + (setf ldwrku n))) + (setf itau + (f2cl-lib:int-add iu + (f2cl-lib:int-mul ldwrku n))) + (setf iwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "L" m n a lda u ldu) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorgqr m m n u ldu + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (dlacpy "U" n n a lda + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku) + (dlaset "L" (f2cl-lib:int-sub n 1) + (f2cl-lib:int-sub n 1) zero zero + (f2cl-lib:array-slice work + double-float + ((+ iu 1)) + ((1 *))) + ldwrku) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf iwork (f2cl-lib:int-add itaup n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd n n + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (dlacpy "U" n n + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku vt ldvt) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" n n n + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" n n n vt ldvt + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n n n 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + vt ldvt + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14)) + (dgemm "N" "N" m n n one u ldu + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku zero a lda) + (dlacpy "F" m n a lda u ldu)) + (t + (setf itau 1) + (setf iwork (f2cl-lib:int-add itau n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgeqrf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "L" m n a lda u ldu) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorgqr m m n u ldu + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (dlacpy "U" n n a lda vt ldvt) + (dlaset "L" (f2cl-lib:int-sub n 1) + (f2cl-lib:int-sub n 1) zero zero + (f2cl-lib:array-slice vt + double-float + (2 1) + ((1 ldvt) (1 *))) + ldvt) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf iwork (f2cl-lib:int-add itaup n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd n n vt ldvt s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13) + (dormbr "Q" "R" "N" m n n vt ldvt + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + u ldu + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" n n n vt ldvt + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n n m 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + vt ldvt u ldu dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14))))))))) + (t + (setf ie 1) + (setf itauq (f2cl-lib:int-add ie n)) + (setf itaup (f2cl-lib:int-add itauq n)) + (setf iwork (f2cl-lib:int-add itaup n)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10) + (dgebrd m n a lda s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf ierr var-10)) + (cond + (wntuas + (dlacpy "L" m n a lda u ldu) + (if wntus (setf ncu n)) + (if wntua (setf ncu m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dorgbr "Q" m ncu n u ldu + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8)) + (setf ierr var-9)))) + (cond + (wntvas + (dlacpy "U" n n a lda vt ldvt) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dorgbr "P" n n n vt ldvt + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8)) + (setf ierr var-9)))) + (cond + (wntuo + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dorgbr "Q" m n n a lda + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8)) + (setf ierr var-9)))) + (cond + (wntvo + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dorgbr "P" n n n a lda + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8)) + (setf ierr var-9)))) + (setf iwork (f2cl-lib:int-add ie n)) + (if (or wntuas wntuo) (setf nru m)) + (if wntun (setf nru 0)) + (if (or wntvas wntvo) (setf ncvt n)) + (if wntvn (setf ncvt 0)) + (cond + ((and (not wntuo) (not wntvo)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n ncvt nru 0 s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) vt + ldvt u ldu dum 1 + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12 + var-13)) + (setf info var-14))) + ((and (not wntuo) wntvo) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n ncvt nru 0 s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) a + lda u ldu dum 1 + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12 + var-13)) + (setf info var-14))) + (t + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" n ncvt nru 0 s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) vt + ldvt a lda dum 1 + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12 + var-13)) + (setf info var-14))))))) + (t + (cond + ((>= n mnthr) + (cond + (wntvn + (setf itau 1) + (setf iwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work double-float (itau) ((1 *))) + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6)) + (setf ierr var-7)) + (dlaset "U" (f2cl-lib:int-sub m 1) (f2cl-lib:int-sub m 1) zero + zero + (f2cl-lib:array-slice a double-float (1 2) ((1 lda) (1 *))) + lda) + (setf ie 1) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf iwork (f2cl-lib:int-add itaup m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10) + (dgebrd m m a lda s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf ierr var-10)) + (cond + ((or wntuo wntuas) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" m m m a lda + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)))) + (setf iwork (f2cl-lib:int-add ie m)) + (setf nru 0) + (if (or wntuo wntuas) (setf nru m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" m 0 nru 0 s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) dum + 1 a lda dum 1 + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12 + var-13)) + (setf info var-14)) + (if wntuas (dlacpy "F" m m a lda u ldu))) + ((and wntvo wntun) + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul m m) + (max + (the fixnum + (f2cl-lib:int-mul 4 m)) + (the fixnum bdspac)))) + (setf ir 1) + (cond + ((>= lwork + (f2cl-lib:int-add + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add + (f2cl-lib:int-mul lda n) + m))) + (f2cl-lib:int-mul lda m))) + (setf ldwrku lda) + (setf chunk n) + (setf ldwrkr lda)) + ((>= lwork + (f2cl-lib:int-add + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add + (f2cl-lib:int-mul lda n) + m))) + (f2cl-lib:int-mul m m))) + (setf ldwrku lda) + (setf chunk n) + (setf ldwrkr m)) + (t + (setf ldwrku m) + (setf chunk + (the fixnum + (truncate (- lwork (* m m) m) m))) + (setf ldwrkr m))) + (setf itau + (f2cl-lib:int-add ir (f2cl-lib:int-mul ldwrkr m))) + (setf iwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "L" m m a lda + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr) + (dlaset "U" (f2cl-lib:int-sub m 1) (f2cl-lib:int-sub m 1) + zero zero + (f2cl-lib:array-slice work + double-float + ((+ ir ldwrkr)) + ((1 *))) + ldwrkr) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorglq m n m a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf iwork (f2cl-lib:int-add itaup m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd m m + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" m m m + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" m m 0 0 s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr dum 1 dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14)) + (setf iu (f2cl-lib:int-add ie m)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i chunk)) + ((> i n) nil) + (tagbody + (setf blk + (min + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-sub n i) + 1)) + (the fixnum chunk))) + (dgemm "N" "N" m blk m one + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr + (f2cl-lib:array-slice a + double-float + (1 i) + ((1 lda) (1 *))) + lda zero + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku) + (dlacpy "F" m blk + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku + (f2cl-lib:array-slice a + double-float + (1 i) + ((1 lda) (1 *))) + lda)))) + (t + (setf ie 1) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf iwork (f2cl-lib:int-add itaup m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd m n a lda s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" m n m a lda + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "L" m n 0 0 s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + a lda dum 1 dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14))))) + ((and wntvo wntuas) + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul m m) + (max + (the fixnum + (f2cl-lib:int-mul 4 m)) + (the fixnum bdspac)))) + (setf ir 1) + (cond + ((>= lwork + (f2cl-lib:int-add + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add + (f2cl-lib:int-mul lda n) + m))) + (f2cl-lib:int-mul lda m))) + (setf ldwrku lda) + (setf chunk n) + (setf ldwrkr lda)) + ((>= lwork + (f2cl-lib:int-add + (max (the fixnum wrkbl) + (the fixnum + (f2cl-lib:int-add + (f2cl-lib:int-mul lda n) + m))) + (f2cl-lib:int-mul m m))) + (setf ldwrku lda) + (setf chunk n) + (setf ldwrkr m)) + (t + (setf ldwrku m) + (setf chunk + (the fixnum + (truncate (- lwork (* m m) m) m))) + (setf ldwrkr m))) + (setf itau + (f2cl-lib:int-add ir (f2cl-lib:int-mul ldwrkr m))) + (setf iwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "L" m m a lda u ldu) + (dlaset "U" (f2cl-lib:int-sub m 1) (f2cl-lib:int-sub m 1) + zero zero + (f2cl-lib:array-slice u + double-float + (1 2) + ((1 ldu) (1 *))) + ldu) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorglq m n m a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf iwork (f2cl-lib:int-add itaup m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd m m u ldu s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (dlacpy "U" m m u ldu + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" m m m + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" m m m u ldu + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" m m m 0 s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr u ldu dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14)) + (setf iu (f2cl-lib:int-add ie m)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i chunk)) + ((> i n) nil) + (tagbody + (setf blk + (min + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-sub n i) + 1)) + (the fixnum chunk))) + (dgemm "N" "N" m blk m one + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr + (f2cl-lib:array-slice a + double-float + (1 i) + ((1 lda) (1 *))) + lda zero + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku) + (dlacpy "F" m blk + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku + (f2cl-lib:array-slice a + double-float + (1 i) + ((1 lda) (1 *))) + lda)))) + (t + (setf itau 1) + (setf iwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "L" m m a lda u ldu) + (dlaset "U" (f2cl-lib:int-sub m 1) (f2cl-lib:int-sub m 1) + zero zero + (f2cl-lib:array-slice u + double-float + (1 2) + ((1 ldu) (1 *))) + ldu) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorglq m n m a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf iwork (f2cl-lib:int-add itaup m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd m m u ldu s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13) + (dormbr "P" "L" "T" m n m u ldu + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + a lda + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" m m m u ldu + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" m n m 0 s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + a lda u ldu dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14))))) + (wntvs + (cond + (wntun + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul m m) + (max + (the fixnum + (f2cl-lib:int-mul 4 m)) + (the fixnum bdspac)))) + (setf ir 1) + (cond + ((>= lwork + (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda m))) + (setf ldwrkr lda)) + (t + (setf ldwrkr m))) + (setf itau + (f2cl-lib:int-add ir + (f2cl-lib:int-mul ldwrkr m))) + (setf iwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "L" m m a lda + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr) + (dlaset "U" (f2cl-lib:int-sub m 1) + (f2cl-lib:int-sub m 1) zero zero + (f2cl-lib:array-slice work + double-float + ((+ ir ldwrkr)) + ((1 *))) + ldwrkr) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorglq m n m a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf iwork (f2cl-lib:int-add itaup m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd m m + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" m m m + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" m m 0 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr dum 1 dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14)) + (dgemm "N" "N" m n m one + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr a lda zero vt ldvt)) + (t + (setf itau 1) + (setf iwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "U" m n a lda vt ldvt) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorglq m n m vt ldvt + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf iwork (f2cl-lib:int-add itaup m)) + (dlaset "U" (f2cl-lib:int-sub m 1) + (f2cl-lib:int-sub m 1) zero zero + (f2cl-lib:array-slice a + double-float + (1 2) + ((1 lda) (1 *))) + lda) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd m m a lda s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13) + (dormbr "P" "L" "T" m n m a lda + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + vt ldvt + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12)) + (setf ierr var-13)) + (setf iwork (f2cl-lib:int-add ie m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" m n 0 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + vt ldvt dum 1 dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14))))) + (wntuo + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul 2 m m) + (max + (the fixnum + (f2cl-lib:int-mul 4 m)) + (the fixnum bdspac)))) + (setf iu 1) + (cond + ((>= lwork + (f2cl-lib:int-add wrkbl + (f2cl-lib:int-mul 2 lda m))) + (setf ldwrku lda) + (setf ir + (f2cl-lib:int-add iu + (f2cl-lib:int-mul ldwrku + m))) + (setf ldwrkr lda)) + ((>= lwork + (f2cl-lib:int-add wrkbl + (f2cl-lib:int-mul + (f2cl-lib:int-add lda m) + m))) + (setf ldwrku lda) + (setf ir + (f2cl-lib:int-add iu + (f2cl-lib:int-mul ldwrku + m))) + (setf ldwrkr m)) + (t + (setf ldwrku m) + (setf ir + (f2cl-lib:int-add iu + (f2cl-lib:int-mul ldwrku + m))) + (setf ldwrkr m))) + (setf itau + (f2cl-lib:int-add ir + (f2cl-lib:int-mul ldwrkr m))) + (setf iwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "L" m m a lda + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku) + (dlaset "U" (f2cl-lib:int-sub m 1) + (f2cl-lib:int-sub m 1) zero zero + (f2cl-lib:array-slice work + double-float + ((+ iu ldwrku)) + ((1 *))) + ldwrku) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorglq m n m a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf iwork (f2cl-lib:int-add itaup m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd m m + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (dlacpy "L" m m + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" m m m + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" m m m + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" m m m 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14)) + (dgemm "N" "N" m n m one + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku a lda zero vt ldvt) + (dlacpy "F" m m + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr a lda)) + (t + (setf itau 1) + (setf iwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "U" m n a lda vt ldvt) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorglq m n m vt ldvt + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf iwork (f2cl-lib:int-add itaup m)) + (dlaset "U" (f2cl-lib:int-sub m 1) + (f2cl-lib:int-sub m 1) zero zero + (f2cl-lib:array-slice a + double-float + (1 2) + ((1 lda) (1 *))) + lda) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd m m a lda s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13) + (dormbr "P" "L" "T" m n m a lda + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + vt ldvt + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" m m m a lda + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" m n m 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + vt ldvt a lda dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14))))) + (wntuas + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul m m) + (max + (the fixnum + (f2cl-lib:int-mul 4 m)) + (the fixnum bdspac)))) + (setf iu 1) + (cond + ((>= lwork + (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda m))) + (setf ldwrku lda)) + (t + (setf ldwrku m))) + (setf itau + (f2cl-lib:int-add iu + (f2cl-lib:int-mul ldwrku m))) + (setf iwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "L" m m a lda + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku) + (dlaset "U" (f2cl-lib:int-sub m 1) + (f2cl-lib:int-sub m 1) zero zero + (f2cl-lib:array-slice work + double-float + ((+ iu ldwrku)) + ((1 *))) + ldwrku) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorglq m n m a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf iwork (f2cl-lib:int-add itaup m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd m m + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (dlacpy "L" m m + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku u ldu) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" m m m + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" m m m u ldu + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" m m m 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku u ldu dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14)) + (dgemm "N" "N" m n m one + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku a lda zero vt ldvt)) + (t + (setf itau 1) + (setf iwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "U" m n a lda vt ldvt) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorglq m n m vt ldvt + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (dlacpy "L" m m a lda u ldu) + (dlaset "U" (f2cl-lib:int-sub m 1) + (f2cl-lib:int-sub m 1) zero zero + (f2cl-lib:array-slice u + double-float + (1 2) + ((1 ldu) (1 *))) + ldu) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf iwork (f2cl-lib:int-add itaup m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd m m u ldu s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13) + (dormbr "P" "L" "T" m n m u ldu + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + vt ldvt + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" m m m u ldu + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" m n m 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + vt ldvt u ldu dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14))))))) + (wntva + (cond + (wntun + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul m m) + (max + (the fixnum + (f2cl-lib:int-add n m)) + (the fixnum + (f2cl-lib:int-mul 4 m)) + (the fixnum bdspac)))) + (setf ir 1) + (cond + ((>= lwork + (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda m))) + (setf ldwrkr lda)) + (t + (setf ldwrkr m))) + (setf itau + (f2cl-lib:int-add ir + (f2cl-lib:int-mul ldwrkr m))) + (setf iwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "U" m n a lda vt ldvt) + (dlacpy "L" m m a lda + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr) + (dlaset "U" (f2cl-lib:int-sub m 1) + (f2cl-lib:int-sub m 1) zero zero + (f2cl-lib:array-slice work + double-float + ((+ ir ldwrkr)) + ((1 *))) + ldwrkr) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorglq n n m vt ldvt + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf iwork (f2cl-lib:int-add itaup m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd m m + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" m m m + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" m m 0 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr dum 1 dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14)) + (dgemm "N" "N" m n m one + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr vt ldvt zero a lda) + (dlacpy "F" m n a lda vt ldvt)) + (t + (setf itau 1) + (setf iwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "U" m n a lda vt ldvt) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorglq n n m vt ldvt + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf iwork (f2cl-lib:int-add itaup m)) + (dlaset "U" (f2cl-lib:int-sub m 1) + (f2cl-lib:int-sub m 1) zero zero + (f2cl-lib:array-slice a + double-float + (1 2) + ((1 lda) (1 *))) + lda) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd m m a lda s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13) + (dormbr "P" "L" "T" m n m a lda + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + vt ldvt + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12)) + (setf ierr var-13)) + (setf iwork (f2cl-lib:int-add ie m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" m n 0 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + vt ldvt dum 1 dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14))))) + (wntuo + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul 2 m m) + (max + (the fixnum + (f2cl-lib:int-add n m)) + (the fixnum + (f2cl-lib:int-mul 4 m)) + (the fixnum bdspac)))) + (setf iu 1) + (cond + ((>= lwork + (f2cl-lib:int-add wrkbl + (f2cl-lib:int-mul 2 lda m))) + (setf ldwrku lda) + (setf ir + (f2cl-lib:int-add iu + (f2cl-lib:int-mul ldwrku + m))) + (setf ldwrkr lda)) + ((>= lwork + (f2cl-lib:int-add wrkbl + (f2cl-lib:int-mul + (f2cl-lib:int-add lda m) + m))) + (setf ldwrku lda) + (setf ir + (f2cl-lib:int-add iu + (f2cl-lib:int-mul ldwrku + m))) + (setf ldwrkr m)) + (t + (setf ldwrku m) + (setf ir + (f2cl-lib:int-add iu + (f2cl-lib:int-mul ldwrku + m))) + (setf ldwrkr m))) + (setf itau + (f2cl-lib:int-add ir + (f2cl-lib:int-mul ldwrkr m))) + (setf iwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "U" m n a lda vt ldvt) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorglq n n m vt ldvt + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (dlacpy "L" m m a lda + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku) + (dlaset "U" (f2cl-lib:int-sub m 1) + (f2cl-lib:int-sub m 1) zero zero + (f2cl-lib:array-slice work + double-float + ((+ iu ldwrku)) + ((1 *))) + ldwrku) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf iwork (f2cl-lib:int-add itaup m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd m m + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (dlacpy "L" m m + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" m m m + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" m m m + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" m m m 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku + (f2cl-lib:array-slice work + double-float + (ir) + ((1 *))) + ldwrkr dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14)) + (dgemm "N" "N" m n m one + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku vt ldvt zero a lda) + (dlacpy "F" m n a lda vt ldvt) + (dlacpy "F" m m + (f2cl-lib:array-slice work double-float (ir) ((1 *))) + ldwrkr a lda)) + (t + (setf itau 1) + (setf iwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "U" m n a lda vt ldvt) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorglq n n m vt ldvt + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf iwork (f2cl-lib:int-add itaup m)) + (dlaset "U" (f2cl-lib:int-sub m 1) + (f2cl-lib:int-sub m 1) zero zero + (f2cl-lib:array-slice a + double-float + (1 2) + ((1 lda) (1 *))) + lda) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd m m a lda s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13) + (dormbr "P" "L" "T" m n m a lda + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + vt ldvt + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" m m m a lda + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" m n m 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + vt ldvt a lda dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14))))) + (wntuas + (cond + ((>= lwork + (f2cl-lib:int-add (f2cl-lib:int-mul m m) + (max + (the fixnum + (f2cl-lib:int-add n m)) + (the fixnum + (f2cl-lib:int-mul 4 m)) + (the fixnum bdspac)))) + (setf iu 1) + (cond + ((>= lwork + (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda m))) + (setf ldwrku lda)) + (t + (setf ldwrku m))) + (setf itau + (f2cl-lib:int-add iu + (f2cl-lib:int-mul ldwrku m))) + (setf iwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "U" m n a lda vt ldvt) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorglq n n m vt ldvt + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (dlacpy "L" m m a lda + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku) + (dlaset "U" (f2cl-lib:int-sub m 1) + (f2cl-lib:int-sub m 1) zero zero + (f2cl-lib:array-slice work + double-float + ((+ iu ldwrku)) + ((1 *))) + ldwrku) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf iwork (f2cl-lib:int-add itaup m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd m m + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (dlacpy "L" m m + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku u ldu) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "P" m m m + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" m m m u ldu + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" m m m 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iu) + ((1 *))) + ldwrku u ldu dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14)) + (dgemm "N" "N" m n m one + (f2cl-lib:array-slice work double-float (iu) ((1 *))) + ldwrku vt ldvt zero a lda) + (dlacpy "F" m n a lda vt ldvt)) + (t + (setf itau 1) + (setf iwork (f2cl-lib:int-add itau m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dgelqf m n a lda + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6)) + (setf ierr var-7)) + (dlacpy "U" m n a lda vt ldvt) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8) + (dorglq n n m vt ldvt + (f2cl-lib:array-slice work + double-float + (itau) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7)) + (setf ierr var-8)) + (dlacpy "L" m m a lda u ldu) + (dlaset "U" (f2cl-lib:int-sub m 1) + (f2cl-lib:int-sub m 1) zero zero + (f2cl-lib:array-slice u + double-float + (1 2) + ((1 ldu) (1 *))) + ldu) + (setf ie itau) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf iwork (f2cl-lib:int-add itaup m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10) + (dgebrd m m u ldu s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf ierr var-10)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13) + (dormbr "P" "L" "T" m n m u ldu + (f2cl-lib:array-slice work + double-float + (itaup) + ((1 *))) + vt ldvt + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12)) + (setf ierr var-13)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9) + (dorgbr "Q" m m m u ldu + (f2cl-lib:array-slice work + double-float + (itauq) + ((1 *))) + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8)) + (setf ierr var-9)) + (setf iwork (f2cl-lib:int-add ie m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "U" m n m 0 s + (f2cl-lib:array-slice work + double-float + (ie) + ((1 *))) + vt ldvt u ldu dum 1 + (f2cl-lib:array-slice work + double-float + (iwork) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9 var-10 var-11 + var-12 var-13)) + (setf info var-14))))))))) + (t + (setf ie 1) + (setf itauq (f2cl-lib:int-add ie m)) + (setf itaup (f2cl-lib:int-add itauq m)) + (setf iwork (f2cl-lib:int-add itaup m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10) + (dgebrd m n a lda s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf ierr var-10)) + (cond + (wntuas + (dlacpy "L" m m a lda u ldu) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dorgbr "Q" m m n u ldu + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8)) + (setf ierr var-9)))) + (cond + (wntvas + (dlacpy "U" m n a lda vt ldvt) + (if wntva (setf nrvt n)) + (if wntvs (setf nrvt m)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dorgbr "P" nrvt n m vt ldvt + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8)) + (setf ierr var-9)))) + (cond + (wntuo + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dorgbr "Q" m m n a lda + (f2cl-lib:array-slice work double-float (itauq) ((1 *))) + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8)) + (setf ierr var-9)))) + (cond + (wntvo + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dorgbr "P" m n m a lda + (f2cl-lib:array-slice work double-float (itaup) ((1 *))) + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwork) 1) ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8)) + (setf ierr var-9)))) + (setf iwork (f2cl-lib:int-add ie m)) + (if (or wntuas wntuo) (setf nru m)) + (if wntun (setf nru 0)) + (if (or wntvas wntvo) (setf ncvt n)) + (if wntvn (setf ncvt 0)) + (cond + ((and (not wntuo) (not wntvo)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "L" m ncvt nru 0 s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) vt + ldvt u ldu dum 1 + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12 + var-13)) + (setf info var-14))) + ((and (not wntuo) wntvo) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "L" m ncvt nru 0 s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) a + lda u ldu dum 1 + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12 + var-13)) + (setf info var-14))) + (t + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13 var-14) + (dbdsqr "L" m ncvt nru 0 s + (f2cl-lib:array-slice work double-float (ie) ((1 *))) vt + ldvt a lda dum 1 + (f2cl-lib:array-slice work double-float (iwork) ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12 + var-13)) + (setf info var-14)))))))) + (cond + ((/= info 0) + (cond + ((> ie 2) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add minmn (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add i ie) + 1)) + ((1 *)) + work-%offset%)))))) + (cond + ((< ie 2) + (f2cl-lib:fdo (i (f2cl-lib:int-add minmn (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add i ie) + 1)) + ((1 *)) + work-%offset%)))))))) + (cond + ((= iscl 1) + (if (> anrm bignum) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dlascl "G" 0 0 bignum anrm minmn 1 s minmn ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8)) + (setf ierr var-9))) + (if (and (/= info 0) (> anrm bignum)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dlascl "G" 0 0 bignum anrm (f2cl-lib:int-sub minmn 1) 1 + (f2cl-lib:array-slice work double-float (2) ((1 *))) minmn + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8)) + (setf ierr var-9))) + (if (< anrm smlnum) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dlascl "G" 0 0 smlnum anrm minmn 1 s minmn ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8)) + (setf ierr var-9))) + (if (and (/= info 0) (< anrm smlnum)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dlascl "G" 0 0 smlnum anrm (f2cl-lib:int-sub minmn 1) 1 + (f2cl-lib:array-slice work double-float (2) ((1 *))) minmn + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8)) + (setf ierr var-9))))) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum maxwrk) 'double-float)) + end_label + (return + (values nil nil nil nil nil nil nil nil nil nil nil nil nil info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgesvd + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + (simple-array character (1)) + fixnum fixnum + (array double-float (*)) fixnum + (array double-float (*)) (array double-float (*)) + fixnum (array double-float (*)) + fixnum (array double-float (*)) + fixnum + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dorglq fortran-to-lisp::dgelqf + fortran-to-lisp::dormbr fortran-to-lisp::dgemm + fortran-to-lisp::dorgqr fortran-to-lisp::dlacpy + fortran-to-lisp::dbdsqr fortran-to-lisp::dorgbr + fortran-to-lisp::dgebrd fortran-to-lisp::dlaset + fortran-to-lisp::dgeqrf fortran-to-lisp::dlascl + fortran-to-lisp::dlange fortran-to-lisp::dlamch + fortran-to-lisp::xerbla fortran-to-lisp::lsame + fortran-to-lisp::ilaenv)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgesv LAPACK} +\pagehead{dgesv}{dgesv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun dgesv (n nrhs a lda ipiv b ldb$ info) + (declare (type (array fixnum (*)) ipiv) + (type (array double-float (*)) b a) + (type fixnum info ldb$ lda nrhs n)) + (f2cl-lib:with-multi-array-data + ((a double-float a-%data% a-%offset%) + (b double-float b-%data% b-%offset%) + (ipiv fixnum ipiv-%data% ipiv-%offset%)) + (prog () + (declare) + (setf info 0) + (cond + ((< n 0) + (setf info -1)) + ((< nrhs 0) + (setf info -2)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info -4)) + ((< ldb$ (max (the fixnum 1) (the fixnum n))) + (setf info -7))) + (cond + ((/= info 0) + (xerbla "DGESV " (f2cl-lib:int-sub info)) + (go end_label))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5) + (dgetrf n n a lda ipiv info) + (declare (ignore var-0 var-1 var-2 var-3 var-4)) + (setf info var-5)) + (cond + ((= info 0) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dgetrs "No transpose" n nrhs a lda ipiv b ldb$ info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)) + (setf info var-8)))) + (go end_label) + end_label + (return (values nil nil nil nil nil nil nil info))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgesv fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (array double-float (*)) fixnum + (array fixnum (*)) + (array double-float (*)) fixnum + fixnum) + :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::dgetrs fortran-to-lisp::dgetrf + fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgetf2 LAPACK} +\pagehead{dgetf2}{dgetf2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(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 dgetf2 (m n a lda ipiv info) + (declare (type (array fixnum (*)) ipiv) + (type (array double-float (*)) a) + (type fixnum info lda n m)) + (f2cl-lib:with-multi-array-data + ((a double-float a-%data% a-%offset%) + (ipiv fixnum ipiv-%data% ipiv-%offset%)) + (prog ((j 0) (jp 0)) + (declare (type fixnum j jp)) + (setf info 0) + (cond + ((< m 0) + (setf info -1)) + ((< n 0) + (setf info -2)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info -4))) + (cond + ((/= info 0) + (xerbla "DGETF2" (f2cl-lib:int-sub info)) + (go end_label))) + (if (or (= m 0) (= n 0)) (go end_label)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j + (min (the fixnum m) + (the fixnum n))) + nil) + (tagbody + (setf jp + (f2cl-lib:int-add (f2cl-lib:int-sub j 1) + (idamax + (f2cl-lib:int-add (f2cl-lib:int-sub m j) + 1) + (f2cl-lib:array-slice a + double-float + (j j) + ((1 lda) (1 *))) + 1))) + (setf (f2cl-lib:fref ipiv-%data% (j) ((1 *)) ipiv-%offset%) jp) + (cond + ((/= (f2cl-lib:fref a (jp j) ((1 lda) (1 *))) zero) + (if (/= jp j) + (dswap n + (f2cl-lib:array-slice a double-float (j 1) ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice a + double-float + (jp 1) + ((1 lda) (1 *))) + lda)) + (if (< j m) + (dscal (f2cl-lib:int-sub m j) + (/ one + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:array-slice a + double-float + ((+ j 1) j) + ((1 lda) (1 *))) + 1))) + ((= info 0) + (setf info j))) + (cond + ((< j (min (the fixnum m) (the fixnum n))) + (dger (f2cl-lib:int-sub m j) (f2cl-lib:int-sub n j) (- one) + (f2cl-lib:array-slice a + double-float + ((+ j 1) j) + ((1 lda) (1 *))) + 1 + (f2cl-lib:array-slice a + double-float + (j (f2cl-lib:int-add j 1)) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice a + double-float + ((+ j 1) (f2cl-lib:int-add j 1)) + ((1 lda) (1 *))) + lda))))) + (go end_label) + end_label + (return (values nil nil nil nil nil info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgetf2 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (array double-float (*)) fixnum + (array fixnum (*)) + fixnum) + :return-values '(nil nil nil nil nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::dger fortran-to-lisp::dscal + fortran-to-lisp::dswap fortran-to-lisp::idamax + fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgetrf LAPACK} +\pagehead{dgetrf}{dgetrf} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0)) + (declare (type (double-float 1.0 1.0) one)) + (defun dgetrf (m n a lda ipiv info) + (declare (type (array fixnum (*)) ipiv) + (type (array double-float (*)) a) + (type fixnum info lda n m)) + (f2cl-lib:with-multi-array-data + ((a double-float a-%data% a-%offset%) + (ipiv fixnum ipiv-%data% ipiv-%offset%)) + (prog ((i 0) (iinfo 0) (j 0) (jb 0) (nb 0)) + (declare (type fixnum i iinfo j jb nb)) + (setf info 0) + (cond + ((< m 0) + (setf info -1)) + ((< n 0) + (setf info -2)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info -4))) + (cond + ((/= info 0) + (xerbla "DGETRF" (f2cl-lib:int-sub info)) + (go end_label))) + (if (or (= m 0) (= n 0)) (go end_label)) + (setf nb (ilaenv 1 "DGETRF" " " m n -1 -1)) + (cond + ((or (<= nb 1) + (>= nb + (min (the fixnum m) (the fixnum n)))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5) + (dgetf2 m n a lda ipiv info) + (declare (ignore var-0 var-1 var-2 var-3 var-4)) + (setf info var-5))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j nb)) + ((> j + (min (the fixnum m) + (the fixnum n))) + nil) + (tagbody + (setf jb + (min + (the fixnum + (f2cl-lib:int-add + (f2cl-lib:int-sub + (min (the fixnum m) + (the fixnum n)) + j) + 1)) + (the fixnum nb))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5) + (dgetf2 (f2cl-lib:int-add (f2cl-lib:int-sub m j) 1) jb + (f2cl-lib:array-slice a double-float (j j) ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice ipiv fixnum (j) ((1 *))) + iinfo) + (declare (ignore var-0 var-1 var-2 var-3 var-4)) + (setf iinfo var-5)) + (if (and (= info 0) (> iinfo 0)) + (setf info (f2cl-lib:int-sub (f2cl-lib:int-add iinfo j) 1))) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum m) + (the fixnum + (f2cl-lib:int-add j + jb + (f2cl-lib:int-sub + 1))))) + nil) + (tagbody + (setf (f2cl-lib:fref ipiv-%data% (i) ((1 *)) ipiv-%offset%) + (f2cl-lib:int-add (f2cl-lib:int-sub j 1) + (f2cl-lib:fref ipiv-%data% + (i) + ((1 *)) + ipiv-%offset%))))) + (dlaswp (f2cl-lib:int-sub j 1) a lda j + (f2cl-lib:int-sub (f2cl-lib:int-add j jb) 1) ipiv 1) + (cond + ((<= (f2cl-lib:int-add j jb) n) + (dlaswp (f2cl-lib:int-add (f2cl-lib:int-sub n j jb) 1) + (f2cl-lib:array-slice a + double-float + (1 (f2cl-lib:int-add j jb)) + ((1 lda) (1 *))) + lda j (f2cl-lib:int-sub (f2cl-lib:int-add j jb) 1) ipiv 1) + (dtrsm "Left" "Lower" "No transpose" "Unit" jb + (f2cl-lib:int-add (f2cl-lib:int-sub n j jb) 1) one + (f2cl-lib:array-slice a double-float (j j) ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice a + double-float + (j (f2cl-lib:int-add j jb)) + ((1 lda) (1 *))) + lda) + (cond + ((<= (f2cl-lib:int-add j jb) m) + (dgemm "No transpose" "No transpose" + (f2cl-lib:int-add (f2cl-lib:int-sub m j jb) 1) + (f2cl-lib:int-add (f2cl-lib:int-sub n j jb) 1) jb (- one) + (f2cl-lib:array-slice a + double-float + ((+ j jb) j) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice a + double-float + (j (f2cl-lib:int-add j jb)) + ((1 lda) (1 *))) + lda one + (f2cl-lib:array-slice a + double-float + ((+ j jb) (f2cl-lib:int-add j jb)) + ((1 lda) (1 *))) + lda))))))))) + end_label + (return (values nil nil nil nil nil info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgetrf + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (array double-float (*)) fixnum + (array fixnum (*)) + fixnum) + :return-values '(nil nil nil nil nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::dgemm fortran-to-lisp::dtrsm + fortran-to-lisp::dlaswp fortran-to-lisp::dgetf2 + fortran-to-lisp::ilaenv fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgetrs LAPACK} +\pagehead{dgetrs}{dgetrs} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0)) + (declare (type (double-float 1.0 1.0) one)) + (defun dgetrs (trans n nrhs a lda ipiv b ldb$ info) + (declare (type (array fixnum (*)) ipiv) + (type (array double-float (*)) b a) + (type fixnum info ldb$ lda nrhs n) + (type (simple-array character (*)) trans)) + (f2cl-lib:with-multi-array-data + ((trans character trans-%data% trans-%offset%) + (a double-float a-%data% a-%offset%) + (b double-float b-%data% b-%offset%) + (ipiv fixnum ipiv-%data% ipiv-%offset%)) + (prog ((notran nil)) + (declare (type (member t nil) notran)) + (setf info 0) + (setf notran (lsame trans "N")) + (cond + ((and (not notran) (not (lsame trans "T")) (not (lsame trans "C"))) + (setf info -1)) + ((< n 0) + (setf info -2)) + ((< nrhs 0) + (setf info -3)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info -5)) + ((< ldb$ (max (the fixnum 1) (the fixnum n))) + (setf info -8))) + (cond + ((/= info 0) + (xerbla "DGETRS" (f2cl-lib:int-sub info)) + (go end_label))) + (if (or (= n 0) (= nrhs 0)) (go end_label)) + (cond + (notran + (dlaswp nrhs b ldb$ 1 n ipiv 1) + (dtrsm "Left" "Lower" "No transpose" "Unit" n nrhs one a lda b ldb$) + (dtrsm "Left" "Upper" "No transpose" "Non-unit" n nrhs one a lda b + ldb$)) + (t + (dtrsm "Left" "Upper" "Transpose" "Non-unit" n nrhs one a lda b ldb$) + (dtrsm "Left" "Lower" "Transpose" "Unit" n nrhs one a lda b ldb$) + (dlaswp nrhs b ldb$ 1 n ipiv -1))) + (go end_label) + end_label + (return (values nil nil nil nil nil nil nil nil info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dgetrs + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum fixnum + (array double-float (*)) fixnum + (array fixnum (*)) + (array double-float (*)) fixnum + fixnum) + :return-values '(nil nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dtrsm fortran-to-lisp::dlaswp + fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dhseqr LAPACK} +\pagehead{dhseqr}{dhseqr} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0) (one 1.0) (two 2.0) (const 1.5) (nsmax 15) (lds nsmax)) + (declare (type (double-float 0.0 0.0) zero) + (type (double-float 1.0 1.0) one) + (type (double-float 2.0 2.0) two) + (type (double-float 1.5 1.5) const) + (type (fixnum 15 15) nsmax) + (type fixnum lds)) + (defun dhseqr (job compz n ilo ihi h ldh wr wi z ldz work lwork info) + (declare (type (array double-float (*)) work z wi wr h) + (type fixnum info lwork ldz ldh ihi ilo n) + (type (simple-array character (*)) compz job)) + (f2cl-lib:with-multi-array-data + ((job character job-%data% job-%offset%) + (compz character compz-%data% compz-%offset%) + (h double-float h-%data% h-%offset%) + (wr double-float wr-%data% wr-%offset%) + (wi double-float wi-%data% wi-%offset%) + (z double-float z-%data% z-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((s + (make-array (the fixnum (reduce #'* (list lds nsmax))) + :element-type 'double-float)) + (v + (make-array (f2cl-lib:int-add nsmax 1) + :element-type 'double-float)) + (vv + (make-array (f2cl-lib:int-add nsmax 1) + :element-type 'double-float)) + (absw 0.0) (ovfl 0.0) (smlnum 0.0) (tau 0.0) (temp 0.0) (tst1 0.0) + (ulp 0.0) (unfl 0.0) (i 0) (i1 0) (i2 0) (ierr 0) (ii 0) (itemp 0) + (itn 0) (its 0) (j 0) (k 0) (l 0) (maxb 0) (nh 0) (nr 0) (ns 0) + (nv 0) (initz nil) (lquery nil) (wantt nil) (wantz nil)) + (declare (type (array double-float (*)) s v vv) + (type (double-float) absw ovfl smlnum tau temp tst1 ulp unfl) + (type fixnum i i1 i2 ierr ii itemp itn its j k l + maxb nh nr ns nv) + (type (member t nil) initz lquery wantt wantz)) + (setf wantt (lsame job "S")) + (setf initz (lsame compz "I")) + (setf wantz (or initz (lsame compz "V"))) + (setf info 0) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce + (the fixnum + (max (the fixnum 1) + (the fixnum n))) + 'double-float)) + (setf lquery (coerce (= lwork -1) '(member t nil))) + (cond + ((and (not (lsame job "E")) (not wantt)) + (setf info -1)) + ((and (not (lsame compz "N")) (not wantz)) + (setf info -2)) + ((< n 0) + (setf info -3)) + ((or (< ilo 1) + (> ilo + (max (the fixnum 1) (the fixnum n)))) + (setf info -4)) + ((or + (< ihi (min (the fixnum ilo) (the fixnum n))) + (> ihi n)) + (setf info -5)) + ((< ldh (max (the fixnum 1) (the fixnum n))) + (setf info -7)) + ((or (< ldz 1) + (and wantz + (< ldz + (max (the fixnum 1) + (the fixnum n))))) + (setf info -11)) + ((and + (< lwork (max (the fixnum 1) (the fixnum n))) + (not lquery)) + (setf info -13))) + (cond + ((/= info 0) + (xerbla "DHSEQR" (f2cl-lib:int-sub info)) + (go end_label)) + (lquery + (go end_label))) + (if initz (dlaset "Full" n n zero one z ldz)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add ilo (f2cl-lib:int-sub 1))) nil) + (tagbody + (setf (f2cl-lib:fref wr-%data% (i) ((1 *)) wr-%offset%) + (f2cl-lib:fref h-%data% (i i) ((1 ldh) (1 *)) h-%offset%)) + (setf (f2cl-lib:fref wi-%data% (i) ((1 *)) wi-%offset%) zero))) + (f2cl-lib:fdo (i (f2cl-lib:int-add ihi 1) (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref wr-%data% (i) ((1 *)) wr-%offset%) + (f2cl-lib:fref h-%data% (i i) ((1 ldh) (1 *)) h-%offset%)) + (setf (f2cl-lib:fref wi-%data% (i) ((1 *)) wi-%offset%) zero))) + (if (= n 0) (go end_label)) + (cond + ((= ilo ihi) + (setf (f2cl-lib:fref wr-%data% (ilo) ((1 *)) wr-%offset%) + (f2cl-lib:fref h-%data% + (ilo ilo) + ((1 ldh) (1 *)) + h-%offset%)) + (setf (f2cl-lib:fref wi-%data% (ilo) ((1 *)) wi-%offset%) zero) + (go end_label))) + (f2cl-lib:fdo (j ilo (f2cl-lib:int-add j 1)) + ((> j (f2cl-lib:int-add ihi (f2cl-lib:int-sub 2))) nil) + (tagbody + (f2cl-lib:fdo (i (f2cl-lib:int-add j 2) (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref h-%data% (i j) ((1 ldh) (1 *)) h-%offset%) + zero))))) + (setf nh (f2cl-lib:int-add (f2cl-lib:int-sub ihi ilo) 1)) + (setf ns (ilaenv 4 "DHSEQR" (f2cl-lib:f2cl-// job compz) n ilo ihi -1)) + (setf maxb + (ilaenv 8 "DHSEQR" (f2cl-lib:f2cl-// job compz) n ilo ihi -1)) + (cond + ((or (<= ns 2) (> ns nh) (>= maxb nh)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 + var-10 var-11 var-12 var-13) + (dlahqr wantt wantz n ilo ihi h ldh wr wi ilo ihi z ldz info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12)) + (setf info var-13)) + (go end_label))) + (setf maxb + (max (the fixnum 3) (the fixnum maxb))) + (setf ns + (min (the fixnum ns) + (the fixnum maxb) + (the fixnum nsmax))) + (setf unfl (dlamch "Safe minimum")) + (setf ovfl (/ one unfl)) + (multiple-value-bind (var-0 var-1) + (dlabad unfl ovfl) + (declare (ignore)) + (setf unfl var-0) + (setf ovfl var-1)) + (setf ulp (dlamch "Precision")) + (setf smlnum (* unfl (/ nh ulp))) + (cond + (wantt + (setf i1 1) + (setf i2 n))) + (setf itn (f2cl-lib:int-mul 30 nh)) + (setf i ihi) + label50 + (setf l ilo) + (if (< i ilo) (go label170)) + (f2cl-lib:fdo (its 0 (f2cl-lib:int-add its 1)) + ((> its itn) nil) + (tagbody + (f2cl-lib:fdo (k i (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k (f2cl-lib:int-add l 1)) nil) + (tagbody + (setf tst1 + (+ + (abs + (f2cl-lib:fref h-%data% + ((f2cl-lib:int-sub k 1) + (f2cl-lib:int-sub k 1)) + ((1 ldh) (1 *)) + h-%offset%)) + (abs + (f2cl-lib:fref h-%data% + (k k) + ((1 ldh) (1 *)) + h-%offset%)))) + (if (= tst1 zero) + (setf tst1 + (dlanhs "1" + (f2cl-lib:int-add (f2cl-lib:int-sub i l) 1) + (f2cl-lib:array-slice h + double-float + (l l) + ((1 ldh) (1 *))) + ldh work))) + (if + (<= + (abs + (f2cl-lib:fref h-%data% + (k (f2cl-lib:int-sub k 1)) + ((1 ldh) (1 *)) + h-%offset%)) + (max (* ulp tst1) smlnum)) + (go label70)))) + label70 + (setf l k) + (cond + ((> l ilo) + (setf (f2cl-lib:fref h-%data% + (l (f2cl-lib:int-sub l 1)) + ((1 ldh) (1 *)) + h-%offset%) + zero))) + (if (>= l (f2cl-lib:int-add (f2cl-lib:int-sub i maxb) 1)) + (go label160)) + (cond + ((not wantt) + (setf i1 l) + (setf i2 i))) + (cond + ((or (= its 20) (= its 30)) + (f2cl-lib:fdo (ii (f2cl-lib:int-add i (f2cl-lib:int-sub ns) 1) + (f2cl-lib:int-add ii 1)) + ((> ii i) nil) + (tagbody + (setf (f2cl-lib:fref wr-%data% (ii) ((1 *)) wr-%offset%) + (* const + (+ + (abs + (f2cl-lib:fref h-%data% + (ii (f2cl-lib:int-sub ii 1)) + ((1 ldh) (1 *)) + h-%offset%)) + (abs + (f2cl-lib:fref h-%data% + (ii ii) + ((1 ldh) (1 *)) + h-%offset%))))) + (setf (f2cl-lib:fref wi-%data% (ii) ((1 *)) wi-%offset%) + zero)))) + (t + (dlacpy "Full" ns ns + (f2cl-lib:array-slice h + double-float + ((+ i (f2cl-lib:int-sub ns) 1) + (f2cl-lib:int-add + (f2cl-lib:int-sub i ns) + 1)) + ((1 ldh) (1 *))) + ldh s lds) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9 var-10 var-11 var-12 var-13) + (dlahqr nil nil ns 1 ns s lds + (f2cl-lib:array-slice wr + double-float + ((+ i (f2cl-lib:int-sub ns) 1)) + ((1 *))) + (f2cl-lib:array-slice wi + double-float + ((+ i (f2cl-lib:int-sub ns) 1)) + ((1 *))) + 1 ns z ldz ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9 var-10 var-11 var-12)) + (setf ierr var-13)) + (cond + ((> ierr 0) + (f2cl-lib:fdo (ii 1 (f2cl-lib:int-add ii 1)) + ((> ii ierr) nil) + (tagbody + (setf (f2cl-lib:fref wr-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub i ns) + ii)) + ((1 *)) + wr-%offset%) + (f2cl-lib:fref s (ii ii) ((1 lds) (1 nsmax)))) + (setf (f2cl-lib:fref wi-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub i ns) + ii)) + ((1 *)) + wi-%offset%) + zero))))))) + (setf (f2cl-lib:fref v (1) ((1 (f2cl-lib:int-add nsmax 1)))) one) + (f2cl-lib:fdo (ii 2 (f2cl-lib:int-add ii 1)) + ((> ii (f2cl-lib:int-add ns 1)) nil) + (tagbody + (setf (f2cl-lib:fref v (ii) ((1 (f2cl-lib:int-add nsmax 1)))) + zero))) + (setf nv 1) + (f2cl-lib:fdo (j (f2cl-lib:int-add i (f2cl-lib:int-sub ns) 1) + (f2cl-lib:int-add j 1)) + ((> j i) nil) + (tagbody + (cond + ((>= (f2cl-lib:fref wi (j) ((1 *))) zero) + (cond + ((= (f2cl-lib:fref wi (j) ((1 *))) zero) + (dcopy (f2cl-lib:int-add nv 1) v 1 vv 1) + (dgemv "No transpose" (f2cl-lib:int-add nv 1) nv one + (f2cl-lib:array-slice h + double-float + (l l) + ((1 ldh) (1 *))) + ldh vv 1 + (- (f2cl-lib:fref wr-%data% (j) ((1 *)) wr-%offset%)) v + 1) + (setf nv (f2cl-lib:int-add nv 1))) + ((> (f2cl-lib:fref wi (j) ((1 *))) zero) + (dcopy (f2cl-lib:int-add nv 1) v 1 vv 1) + (dgemv "No transpose" (f2cl-lib:int-add nv 1) nv one + (f2cl-lib:array-slice h + double-float + (l l) + ((1 ldh) (1 *))) + ldh v 1 + (* (- two) + (f2cl-lib:fref wr-%data% (j) ((1 *)) wr-%offset%)) + vv 1) + (setf itemp (idamax (f2cl-lib:int-add nv 1) vv 1)) + (setf temp + (/ one + (max + (abs + (f2cl-lib:fref vv + (itemp) + ((1 + (f2cl-lib:int-add nsmax + 1))))) + smlnum))) + (dscal (f2cl-lib:int-add nv 1) temp vv 1) + (setf absw + (dlapy2 + (f2cl-lib:fref wr-%data% + (j) + ((1 *)) + wr-%offset%) + (f2cl-lib:fref wi-%data% + (j) + ((1 *)) + wi-%offset%))) + (setf temp (* temp absw absw)) + (dgemv "No transpose" (f2cl-lib:int-add nv 2) + (f2cl-lib:int-add nv 1) one + (f2cl-lib:array-slice h + double-float + (l l) + ((1 ldh) (1 *))) + ldh vv 1 temp v 1) + (setf nv (f2cl-lib:int-add nv 2)))) + (setf itemp (idamax nv v 1)) + (setf temp + (abs + (f2cl-lib:fref v + (itemp) + ((1 (f2cl-lib:int-add nsmax 1)))))) + (cond + ((= temp zero) + (setf (f2cl-lib:fref v + (1) + ((1 (f2cl-lib:int-add nsmax 1)))) + one) + (f2cl-lib:fdo (ii 2 (f2cl-lib:int-add ii 1)) + ((> ii nv) nil) + (tagbody + (setf (f2cl-lib:fref v + (ii) + ((1 + (f2cl-lib:int-add nsmax 1)))) + zero)))) + (t + (setf temp (max temp smlnum)) + (dscal nv (/ one temp) v 1))))))) + (f2cl-lib:fdo (k l (f2cl-lib:int-add k 1)) + ((> k (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) nil) + (tagbody + (setf nr + (min (the fixnum (f2cl-lib:int-add ns 1)) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-sub i k) + 1)))) + (if (> k l) + (dcopy nr + (f2cl-lib:array-slice h + double-float + (k (f2cl-lib:int-sub k 1)) + ((1 ldh) (1 *))) + 1 v 1)) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlarfg nr + (f2cl-lib:fref v (1) ((1 (f2cl-lib:int-add nsmax 1)))) + (f2cl-lib:array-slice v + double-float + (2) + ((1 (f2cl-lib:int-add nsmax 1)))) + 1 tau) + (declare (ignore var-0 var-2 var-3)) + (setf (f2cl-lib:fref v (1) ((1 (f2cl-lib:int-add nsmax 1)))) + var-1) + (setf tau var-4)) + (cond + ((> k l) + (setf (f2cl-lib:fref h-%data% + (k (f2cl-lib:int-sub k 1)) + ((1 ldh) (1 *)) + h-%offset%) + (f2cl-lib:fref v + (1) + ((1 (f2cl-lib:int-add nsmax 1))))) + (f2cl-lib:fdo (ii (f2cl-lib:int-add k 1) + (f2cl-lib:int-add ii 1)) + ((> ii i) nil) + (tagbody + (setf (f2cl-lib:fref h-%data% + (ii (f2cl-lib:int-sub k 1)) + ((1 ldh) (1 *)) + h-%offset%) + zero))))) + (setf (f2cl-lib:fref v (1) ((1 (f2cl-lib:int-add nsmax 1)))) + one) + (dlarfx "Left" nr (f2cl-lib:int-add (f2cl-lib:int-sub i2 k) 1) + v tau + (f2cl-lib:array-slice h double-float (k k) ((1 ldh) (1 *))) + ldh work) + (dlarfx "Right" + (f2cl-lib:int-add + (f2cl-lib:int-sub + (min (the fixnum (f2cl-lib:int-add k nr)) + (the fixnum i)) + i1) + 1) + nr v tau + (f2cl-lib:array-slice h double-float (i1 k) ((1 ldh) (1 *))) + ldh work) + (cond + (wantz + (dlarfx "Right" nh nr v tau + (f2cl-lib:array-slice z + double-float + (ilo k) + ((1 ldz) (1 *))) + ldz work))))))) + (setf info i) + (go end_label) + label160 + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 + var-10 var-11 var-12 var-13) + (dlahqr wantt wantz n l i h ldh wr wi ilo ihi z ldz info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-11 var-12)) + (setf info var-13)) + (if (> info 0) (go end_label)) + (setf itn (f2cl-lib:int-sub itn its)) + (setf i (f2cl-lib:int-sub l 1)) + (go label50) + label170 + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce + (the fixnum + (max (the fixnum 1) + (the fixnum n))) + 'double-float)) + end_label + (return + (values nil nil nil nil nil nil nil nil nil nil nil nil nil info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dhseqr + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + (simple-array character (1)) + fixnum fixnum + fixnum (array double-float (*)) + fixnum (array double-float (*)) + (array double-float (*)) (array double-float (*)) + fixnum (array double-float (*)) + fixnum + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlarfx fortran-to-lisp::dlarfg + fortran-to-lisp::dlapy2 fortran-to-lisp::dscal + fortran-to-lisp::idamax fortran-to-lisp::dgemv + fortran-to-lisp::dcopy fortran-to-lisp::dlacpy + fortran-to-lisp::dlanhs fortran-to-lisp::dlabad + fortran-to-lisp::dlamch fortran-to-lisp::dlahqr + fortran-to-lisp::ilaenv fortran-to-lisp::dlaset + fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlabad LAPACK} +\pagehead{dlabad}{dlabad} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun dlabad (small large) + (declare (type (double-float) large small)) + (prog () + (declare) + (cond + ((> (f2cl-lib:log10 large) 2000.0) + (setf small (f2cl-lib:fsqrt small)) + (setf large (f2cl-lib:fsqrt large)))) + (return (values small large)))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dlabad + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((double-float) (double-float)) + :return-values '(fortran-to-lisp::small fortran-to-lisp::large) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlabrd LAPACK} +\pagehead{dlabrd}{dlabrd} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0) (one 1.0)) + (declare (type (double-float 0.0 0.0) zero) + (type (double-float 1.0 1.0) one)) + (defun dlabrd (m n nb a lda d e tauq taup x ldx y ldy) + (declare (type (array double-float (*)) y x taup tauq e d a) + (type fixnum ldy ldx lda nb n m)) + (f2cl-lib:with-multi-array-data + ((a double-float a-%data% a-%offset%) + (d double-float d-%data% d-%offset%) + (e double-float e-%data% e-%offset%) + (tauq double-float tauq-%data% tauq-%offset%) + (taup double-float taup-%data% taup-%offset%) + (x double-float x-%data% x-%offset%) + (y double-float y-%data% y-%offset%)) + (prog ((i 0)) + (declare (type fixnum i)) + (if (or (<= m 0) (<= n 0)) (go end_label)) + (cond + ((>= m n) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i nb) nil) + (tagbody + (dgemv "No transpose" + (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) + (f2cl-lib:int-sub i 1) (- one) + (f2cl-lib:array-slice a double-float (i 1) ((1 lda) (1 *))) lda + (f2cl-lib:array-slice y double-float (i 1) ((1 ldy) (1 *))) ldy + one (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) + 1) + (dgemv "No transpose" + (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) + (f2cl-lib:int-sub i 1) (- one) + (f2cl-lib:array-slice x double-float (i 1) ((1 ldx) (1 *))) ldx + (f2cl-lib:array-slice a double-float (1 i) ((1 lda) (1 *))) 1 + one (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) + 1) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlarfg (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) + (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) + (f2cl-lib:array-slice a + double-float + ((min (f2cl-lib:int-add i 1) m) i) + ((1 lda) (1 *))) + 1 (f2cl-lib:fref tauq-%data% (i) ((1 *)) tauq-%offset%)) + (declare (ignore var-0 var-2 var-3)) + (setf (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%) + var-1) + (setf (f2cl-lib:fref tauq-%data% (i) ((1 *)) tauq-%offset%) + var-4)) + (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (cond + ((< i n) + (setf (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%) + one) + (dgemv "Transpose" + (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) + (f2cl-lib:int-sub n i) one + (f2cl-lib:array-slice a + double-float + (i (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) + 1 zero + (f2cl-lib:array-slice y + double-float + ((+ i 1) i) + ((1 ldy) (1 *))) + 1) + (dgemv "Transpose" + (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) + (f2cl-lib:int-sub i 1) one + (f2cl-lib:array-slice a double-float (i 1) ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) + 1 zero + (f2cl-lib:array-slice y double-float (1 i) ((1 ldy) (1 *))) + 1) + (dgemv "No transpose" (f2cl-lib:int-sub n i) + (f2cl-lib:int-sub i 1) (- one) + (f2cl-lib:array-slice y + double-float + ((+ i 1) 1) + ((1 ldy) (1 *))) + ldy + (f2cl-lib:array-slice y double-float (1 i) ((1 ldy) (1 *))) + 1 one + (f2cl-lib:array-slice y + double-float + ((+ i 1) i) + ((1 ldy) (1 *))) + 1) + (dgemv "Transpose" + (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) + (f2cl-lib:int-sub i 1) one + (f2cl-lib:array-slice x double-float (i 1) ((1 ldx) (1 *))) + ldx + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) + 1 zero + (f2cl-lib:array-slice y double-float (1 i) ((1 ldy) (1 *))) + 1) + (dgemv "Transpose" (f2cl-lib:int-sub i 1) + (f2cl-lib:int-sub n i) (- one) + (f2cl-lib:array-slice a + double-float + (1 (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice y double-float (1 i) ((1 ldy) (1 *))) + 1 one + (f2cl-lib:array-slice y + double-float + ((+ i 1) i) + ((1 ldy) (1 *))) + 1) + (dscal (f2cl-lib:int-sub n i) + (f2cl-lib:fref tauq-%data% (i) ((1 *)) tauq-%offset%) + (f2cl-lib:array-slice y + double-float + ((+ i 1) i) + ((1 ldy) (1 *))) + 1) + (dgemv "No transpose" (f2cl-lib:int-sub n i) i (- one) + (f2cl-lib:array-slice y + double-float + ((+ i 1) 1) + ((1 ldy) (1 *))) + ldy + (f2cl-lib:array-slice a double-float (i 1) ((1 lda) (1 *))) + lda one + (f2cl-lib:array-slice a + double-float + (i (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda) + (dgemv "Transpose" (f2cl-lib:int-sub i 1) + (f2cl-lib:int-sub n i) (- one) + (f2cl-lib:array-slice a + double-float + (1 (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice x double-float (i 1) ((1 ldx) (1 *))) + ldx one + (f2cl-lib:array-slice a + double-float + (i (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlarfg (f2cl-lib:int-sub n i) + (f2cl-lib:fref a-%data% + (i (f2cl-lib:int-add i 1)) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:array-slice a + double-float + (i + (min + (the fixnum + (f2cl-lib:int-add i 2)) + (the fixnum n))) + ((1 lda) (1 *))) + lda + (f2cl-lib:fref taup-%data% (i) ((1 *)) taup-%offset%)) + (declare (ignore var-0 var-2 var-3)) + (setf (f2cl-lib:fref a-%data% + (i (f2cl-lib:int-add i 1)) + ((1 lda) (1 *)) + a-%offset%) + var-1) + (setf (f2cl-lib:fref taup-%data% (i) ((1 *)) taup-%offset%) + var-4)) + (setf (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) + (f2cl-lib:fref a-%data% + (i (f2cl-lib:int-add i 1)) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + (i (f2cl-lib:int-add i 1)) + ((1 lda) (1 *)) + a-%offset%) + one) + (dgemv "No transpose" (f2cl-lib:int-sub m i) + (f2cl-lib:int-sub n i) one + (f2cl-lib:array-slice a + double-float + ((+ i 1) (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice a + double-float + (i (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda zero + (f2cl-lib:array-slice x + double-float + ((+ i 1) i) + ((1 ldx) (1 *))) + 1) + (dgemv "Transpose" (f2cl-lib:int-sub n i) i one + (f2cl-lib:array-slice y + double-float + ((+ i 1) 1) + ((1 ldy) (1 *))) + ldy + (f2cl-lib:array-slice a + double-float + (i (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda zero + (f2cl-lib:array-slice x double-float (1 i) ((1 ldx) (1 *))) + 1) + (dgemv "No transpose" (f2cl-lib:int-sub m i) i (- one) + (f2cl-lib:array-slice a + double-float + ((+ i 1) 1) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice x double-float (1 i) ((1 ldx) (1 *))) + 1 one + (f2cl-lib:array-slice x + double-float + ((+ i 1) i) + ((1 ldx) (1 *))) + 1) + (dgemv "No transpose" (f2cl-lib:int-sub i 1) + (f2cl-lib:int-sub n i) one + (f2cl-lib:array-slice a + double-float + (1 (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice a + double-float + (i (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda zero + (f2cl-lib:array-slice x double-float (1 i) ((1 ldx) (1 *))) + 1) + (dgemv "No transpose" (f2cl-lib:int-sub m i) + (f2cl-lib:int-sub i 1) (- one) + (f2cl-lib:array-slice x + double-float + ((+ i 1) 1) + ((1 ldx) (1 *))) + ldx + (f2cl-lib:array-slice x double-float (1 i) ((1 ldx) (1 *))) + 1 one + (f2cl-lib:array-slice x + double-float + ((+ i 1) i) + ((1 ldx) (1 *))) + 1) + (dscal (f2cl-lib:int-sub m i) + (f2cl-lib:fref taup-%data% (i) ((1 *)) taup-%offset%) + (f2cl-lib:array-slice x + double-float + ((+ i 1) i) + ((1 ldx) (1 *))) + 1)))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i nb) nil) + (tagbody + (dgemv "No transpose" + (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1) + (f2cl-lib:int-sub i 1) (- one) + (f2cl-lib:array-slice y double-float (i 1) ((1 ldy) (1 *))) ldy + (f2cl-lib:array-slice a double-float (i 1) ((1 lda) (1 *))) lda + one (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) + lda) + (dgemv "Transpose" (f2cl-lib:int-sub i 1) + (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1) (- one) + (f2cl-lib:array-slice a double-float (1 i) ((1 lda) (1 *))) lda + (f2cl-lib:array-slice x double-float (i 1) ((1 ldx) (1 *))) ldx + one (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) + lda) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlarfg (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1) + (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) + (f2cl-lib:array-slice a + double-float + (i + (min + (the fixnum + (f2cl-lib:int-add i 1)) + (the fixnum n))) + ((1 lda) (1 *))) + lda (f2cl-lib:fref taup-%data% (i) ((1 *)) taup-%offset%)) + (declare (ignore var-0 var-2 var-3)) + (setf (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%) + var-1) + (setf (f2cl-lib:fref taup-%data% (i) ((1 *)) taup-%offset%) + var-4)) + (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (cond + ((< i m) + (setf (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%) + one) + (dgemv "No transpose" (f2cl-lib:int-sub m i) + (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1) one + (f2cl-lib:array-slice a + double-float + ((+ i 1) i) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) + lda zero + (f2cl-lib:array-slice x + double-float + ((+ i 1) i) + ((1 ldx) (1 *))) + 1) + (dgemv "Transpose" + (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1) + (f2cl-lib:int-sub i 1) one + (f2cl-lib:array-slice y double-float (i 1) ((1 ldy) (1 *))) + ldy + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) + lda zero + (f2cl-lib:array-slice x double-float (1 i) ((1 ldx) (1 *))) + 1) + (dgemv "No transpose" (f2cl-lib:int-sub m i) + (f2cl-lib:int-sub i 1) (- one) + (f2cl-lib:array-slice a + double-float + ((+ i 1) 1) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice x double-float (1 i) ((1 ldx) (1 *))) + 1 one + (f2cl-lib:array-slice x + double-float + ((+ i 1) i) + ((1 ldx) (1 *))) + 1) + (dgemv "No transpose" (f2cl-lib:int-sub i 1) + (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1) one + (f2cl-lib:array-slice a double-float (1 i) ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) + lda zero + (f2cl-lib:array-slice x double-float (1 i) ((1 ldx) (1 *))) + 1) + (dgemv "No transpose" (f2cl-lib:int-sub m i) + (f2cl-lib:int-sub i 1) (- one) + (f2cl-lib:array-slice x + double-float + ((+ i 1) 1) + ((1 ldx) (1 *))) + ldx + (f2cl-lib:array-slice x double-float (1 i) ((1 ldx) (1 *))) + 1 one + (f2cl-lib:array-slice x + double-float + ((+ i 1) i) + ((1 ldx) (1 *))) + 1) + (dscal (f2cl-lib:int-sub m i) + (f2cl-lib:fref taup-%data% (i) ((1 *)) taup-%offset%) + (f2cl-lib:array-slice x + double-float + ((+ i 1) i) + ((1 ldx) (1 *))) + 1) + (dgemv "No transpose" (f2cl-lib:int-sub m i) + (f2cl-lib:int-sub i 1) (- one) + (f2cl-lib:array-slice a + double-float + ((+ i 1) 1) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice y double-float (i 1) ((1 ldy) (1 *))) + ldy one + (f2cl-lib:array-slice a + double-float + ((+ i 1) i) + ((1 lda) (1 *))) + 1) + (dgemv "No transpose" (f2cl-lib:int-sub m i) i (- one) + (f2cl-lib:array-slice x + double-float + ((+ i 1) 1) + ((1 ldx) (1 *))) + ldx + (f2cl-lib:array-slice a double-float (1 i) ((1 lda) (1 *))) + 1 one + (f2cl-lib:array-slice a + double-float + ((+ i 1) i) + ((1 lda) (1 *))) + 1) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlarfg (f2cl-lib:int-sub m i) + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add i 1) i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:array-slice a + double-float + ((min (f2cl-lib:int-add i 2) m) i) + ((1 lda) (1 *))) + 1 (f2cl-lib:fref tauq-%data% (i) ((1 *)) tauq-%offset%)) + (declare (ignore var-0 var-2 var-3)) + (setf (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add i 1) i) + ((1 lda) (1 *)) + a-%offset%) + var-1) + (setf (f2cl-lib:fref tauq-%data% (i) ((1 *)) tauq-%offset%) + var-4)) + (setf (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%) + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add i 1) i) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add i 1) i) + ((1 lda) (1 *)) + a-%offset%) + one) + (dgemv "Transpose" (f2cl-lib:int-sub m i) + (f2cl-lib:int-sub n i) one + (f2cl-lib:array-slice a + double-float + ((+ i 1) (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice a + double-float + ((+ i 1) i) + ((1 lda) (1 *))) + 1 zero + (f2cl-lib:array-slice y + double-float + ((+ i 1) i) + ((1 ldy) (1 *))) + 1) + (dgemv "Transpose" (f2cl-lib:int-sub m i) + (f2cl-lib:int-sub i 1) one + (f2cl-lib:array-slice a + double-float + ((+ i 1) 1) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice a + double-float + ((+ i 1) i) + ((1 lda) (1 *))) + 1 zero + (f2cl-lib:array-slice y double-float (1 i) ((1 ldy) (1 *))) + 1) + (dgemv "No transpose" (f2cl-lib:int-sub n i) + (f2cl-lib:int-sub i 1) (- one) + (f2cl-lib:array-slice y + double-float + ((+ i 1) 1) + ((1 ldy) (1 *))) + ldy + (f2cl-lib:array-slice y double-float (1 i) ((1 ldy) (1 *))) + 1 one + (f2cl-lib:array-slice y + double-float + ((+ i 1) i) + ((1 ldy) (1 *))) + 1) + (dgemv "Transpose" (f2cl-lib:int-sub m i) i one + (f2cl-lib:array-slice x + double-float + ((+ i 1) 1) + ((1 ldx) (1 *))) + ldx + (f2cl-lib:array-slice a + double-float + ((+ i 1) i) + ((1 lda) (1 *))) + 1 zero + (f2cl-lib:array-slice y double-float (1 i) ((1 ldy) (1 *))) + 1) + (dgemv "Transpose" i (f2cl-lib:int-sub n i) (- one) + (f2cl-lib:array-slice a + double-float + (1 (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice y double-float (1 i) ((1 ldy) (1 *))) + 1 one + (f2cl-lib:array-slice y + double-float + ((+ i 1) i) + ((1 ldy) (1 *))) + 1) + (dscal (f2cl-lib:int-sub n i) + (f2cl-lib:fref tauq-%data% (i) ((1 *)) tauq-%offset%) + (f2cl-lib:array-slice y + double-float + ((+ i 1) i) + ((1 ldy) (1 *))) + 1))))))) + end_label + (return + (values nil nil nil nil nil nil nil nil nil nil nil nil nil)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dlabrd + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + fixnum (array double-float (*)) + fixnum (array double-float (*)) + (array double-float (*)) (array double-float (*)) + (array double-float (*)) (array double-float (*)) + fixnum (array double-float (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil + nil) + :calls '(fortran-to-lisp::dscal fortran-to-lisp::dlarfg + fortran-to-lisp::dgemv)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlacon LAPACK} +\pagehead{dlacon}{dlacon} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((itmax 5) (zero 0.0) (one 1.0) (two 2.0)) + (declare (type (fixnum 5 5) itmax) + (type (double-float 0.0 0.0) zero) + (type (double-float 1.0 1.0) one) + (type (double-float 2.0 2.0) two)) + (let ((altsgn 0.0) + (estold 0.0) + (temp 0.0) + (i 0) + (iter 0) + (j 0) + (jlast 0) + (jump 0)) + (declare (type fixnum itmax jump jlast j iter i) + (type (double-float) two one zero temp estold altsgn)) + (defun dlacon (n v x isgn est kase) + (declare (type (double-float) est) + (type (array fixnum (*)) isgn) + (type (array double-float (*)) x v) + (type fixnum kase n)) + (f2cl-lib:with-multi-array-data + ((v double-float v-%data% v-%offset%) + (x double-float x-%data% x-%offset%) + (isgn fixnum isgn-%data% isgn-%offset%)) + (prog () + (declare) + (cond + ((= kase 0) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%) + (/ one (coerce (realpart n) 'double-float))))) + (setf kase 1) + (setf jump 1) + (go end_label))) + (f2cl-lib:computed-goto (label20 label40 label70 label110 label140) + jump) + label20 + (cond + ((= n 1) + (setf (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%) + (f2cl-lib:fref x-%data% (1) ((1 *)) x-%offset%)) + (setf est (abs (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%))) + (go label150))) + (setf est (dasum n x 1)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%) + (f2cl-lib:sign one + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%))) + (setf (f2cl-lib:fref isgn-%data% (i) ((1 *)) isgn-%offset%) + (values (round + (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%)))))) + (setf kase 2) + (setf jump 2) + (go end_label) + label40 + (setf j (idamax n x 1)) + (setf iter 2) + label50 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%) zero))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) one) + (setf kase 1) + (setf jump 3) + (go end_label) + label70 + (dcopy n x 1 v 1) + (setf estold est) + (setf est (dasum n v 1)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (if + (/= + (values (round + (f2cl-lib:sign one + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (f2cl-lib:fref isgn-%data% (i) ((1 *)) isgn-%offset%)) + (go label90)))) + (go label120) + label90 + (if (<= est estold) (go label120)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%) + (f2cl-lib:sign one + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%))) + (setf (f2cl-lib:fref isgn-%data% (i) ((1 *)) isgn-%offset%) + (values (round + (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%)))))) + (setf kase 2) + (setf jump 4) + (go end_label) + label110 + (setf jlast j) + (setf j (idamax n x 1)) + (cond + ((and + (/= (f2cl-lib:fref x (jlast) ((1 *))) + (abs (f2cl-lib:fref x (j) ((1 *))))) + (< iter itmax)) + (setf iter (f2cl-lib:int-add iter 1)) + (go label50))) + label120 + (setf altsgn one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%) + (* altsgn + (+ one + (/ + (coerce (realpart (f2cl-lib:int-sub i 1)) 'double-float) + (coerce (realpart (f2cl-lib:int-sub n 1)) 'double-float))))) + (setf altsgn (- altsgn)))) + (setf kase 1) + (setf jump 5) + (go end_label) + label140 + (setf temp + (* two + (/ (dasum n x 1) + (coerce (realpart (f2cl-lib:int-mul 3 n)) 'double-float)))) + (cond + ((> temp est) + (dcopy n x 1 v 1) + (setf est temp))) + label150 + (setf kase 0) + end_label + (return (values nil nil nil nil est kase))))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dlacon + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum (array double-float (*)) + (array double-float (*)) + (array fixnum (*)) (double-float) + fixnum) + :return-values '(nil nil nil nil fortran-to-lisp::est + fortran-to-lisp::kase) + :calls '(fortran-to-lisp::dcopy fortran-to-lisp::idamax + fortran-to-lisp::dasum)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlacpy LAPACK} +\pagehead{dlacpy}{dlacpy} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun dlacpy (uplo m n a lda b ldb$) + (declare (type (array double-float (*)) b a) + (type fixnum ldb$ lda n m) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (a double-float a-%data% a-%offset%) + (b double-float b-%data% b-%offset%)) + (prog ((i 0) (j 0)) + (declare (type fixnum j i)) + (cond + ((lsame uplo "U") + (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 + (min (the fixnum j) + (the fixnum m))) + nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%))))))) + ((lsame uplo "L") + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%))))))) + (t + (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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))))) + end_label + (return (values nil nil nil nil nil nil nil))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dlacpy + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum fixnum + (array double-float (*)) fixnum + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dladiv LAPACK} +\pagehead{dladiv}{dladiv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun dladiv (a b c d p q) + (declare (type (double-float) q p d c b a)) + (prog ((e 0.0) (f 0.0)) + (declare (type (double-float) f e)) + (cond + ((< (abs d) (abs c)) + (setf e (/ d c)) + (setf f (+ c (* d e))) + (setf p (/ (+ a (* b e)) f)) + (setf q (/ (- b (* a e)) f))) + (t + (setf e (/ c d)) + (setf f (+ d (* c e))) + (setf p (/ (+ b (* a e)) f)) + (setf q (/ (- (* b e) a) f)))) + (return (values nil nil nil nil p q)))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dladiv + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((double-float) (double-float) (double-float) + (double-float) (double-float) (double-float)) + :return-values '(nil nil nil nil fortran-to-lisp::p + fortran-to-lisp::q) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlaed6 LAPACK} +\pagehead{dlaed6}{dlaed6} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((maxit 20) + (zero 0.0) + (one 1.0) + (two 2.0) + (three 3.0) + (four 4.0) + (eight 8.0)) + (declare (type (fixnum 20 20) maxit) + (type (double-float 0.0 0.0) zero) + (type (double-float 1.0 1.0) one) + (type (double-float 2.0 2.0) two) + (type (double-float 3.0 3.0) three) + (type (double-float 4.0 4.0) four) + (type (double-float 8.0 8.0) eight)) + (let ((small1 0.0) + (sminv1 0.0) + (small2 0.0) + (sminv2 0.0) + (eps 0.0) + (first$ nil)) + (declare (type (member t nil) first$) + (type (double-float) eps sminv2 small2 sminv1 small1)) + (setq first$ t) + (defun dlaed6 (kniter orgati rho d z finit tau info) + (declare (type (array double-float (*)) z d) + (type (double-float) tau finit rho) + (type (member t nil) orgati) + (type fixnum info kniter)) + (f2cl-lib:with-multi-array-data + ((d double-float d-%data% d-%offset%) + (z double-float z-%data% z-%offset%)) + (prog ((a 0.0) (b 0.0) (base 0.0) (c 0.0) (ddf 0.0) (df 0.0) + (erretm 0.0) (eta 0.0) (f 0.0) (fc 0.0) (sclfac 0.0) + (sclinv 0.0) (temp 0.0) (temp1 0.0) (temp2 0.0) (temp3 0.0) + (temp4 0.0) (i 0) (iter 0) (niter 0) (scale nil) + (dscale (make-array 3 :element-type 'double-float)) + (zscale (make-array 3 :element-type 'double-float))) + (declare (type (double-float) a b base c ddf df erretm eta f fc + sclfac sclinv temp temp1 temp2 temp3 + temp4) + (type fixnum i iter niter) + (type (member t nil) scale) + (type (array double-float (3)) dscale zscale)) + (setf info 0) + (setf niter 1) + (setf tau zero) + (cond + ((= kniter 2) + (cond + (orgati + (setf temp + (/ + (- (f2cl-lib:fref d-%data% (3) ((1 3)) d-%offset%) + (f2cl-lib:fref d-%data% (2) ((1 3)) d-%offset%)) + two)) + (setf c + (+ rho + (/ (f2cl-lib:fref z-%data% (1) ((1 3)) z-%offset%) + (- + (f2cl-lib:fref d-%data% (1) ((1 3)) d-%offset%) + (f2cl-lib:fref d-%data% (2) ((1 3)) d-%offset%) + temp)))) + (setf a + (+ + (* c + (+ (f2cl-lib:fref d-%data% (2) ((1 3)) d-%offset%) + (f2cl-lib:fref d-%data% + (3) + ((1 3)) + d-%offset%))) + (f2cl-lib:fref z-%data% (2) ((1 3)) z-%offset%) + (f2cl-lib:fref z-%data% (3) ((1 3)) z-%offset%))) + (setf b + (+ + (* c + (f2cl-lib:fref d-%data% (2) ((1 3)) d-%offset%) + (f2cl-lib:fref d-%data% (3) ((1 3)) d-%offset%)) + (* (f2cl-lib:fref z-%data% (2) ((1 3)) z-%offset%) + (f2cl-lib:fref d-%data% (3) ((1 3)) d-%offset%)) + (* (f2cl-lib:fref z-%data% (3) ((1 3)) z-%offset%) + (f2cl-lib:fref d-%data% (2) ((1 3)) d-%offset%))))) + (t + (setf temp + (/ + (- (f2cl-lib:fref d-%data% (1) ((1 3)) d-%offset%) + (f2cl-lib:fref d-%data% (2) ((1 3)) d-%offset%)) + two)) + (setf c + (+ rho + (/ (f2cl-lib:fref z-%data% (3) ((1 3)) z-%offset%) + (- + (f2cl-lib:fref d-%data% (3) ((1 3)) d-%offset%) + (f2cl-lib:fref d-%data% (2) ((1 3)) d-%offset%) + temp)))) + (setf a + (+ + (* c + (+ (f2cl-lib:fref d-%data% (1) ((1 3)) d-%offset%) + (f2cl-lib:fref d-%data% + (2) + ((1 3)) + d-%offset%))) + (f2cl-lib:fref z-%data% (1) ((1 3)) z-%offset%) + (f2cl-lib:fref z-%data% (2) ((1 3)) z-%offset%))) + (setf b + (+ + (* c + (f2cl-lib:fref d-%data% (1) ((1 3)) d-%offset%) + (f2cl-lib:fref d-%data% (2) ((1 3)) d-%offset%)) + (* (f2cl-lib:fref z-%data% (1) ((1 3)) z-%offset%) + (f2cl-lib:fref d-%data% (2) ((1 3)) d-%offset%)) + (* (f2cl-lib:fref z-%data% (2) ((1 3)) z-%offset%) + (f2cl-lib:fref d-%data% (1) ((1 3)) d-%offset%)))))) + (setf temp (max (abs a) (abs b) (abs c))) + (setf a (/ a temp)) + (setf b (/ b temp)) + (setf c (/ c temp)) + (cond + ((= c zero) + (setf tau (/ b a))) + ((<= a zero) + (setf tau + (/ + (- a + (f2cl-lib:fsqrt + (abs (+ (* a a) (* (- four) b c))))) + (* two c)))) + (t + (setf tau + (/ (* two b) + (+ a + (f2cl-lib:fsqrt + (abs (+ (* a a) (* (- four) b c))))))))) + (setf temp + (+ rho + (/ (f2cl-lib:fref z-%data% (1) ((1 3)) z-%offset%) + (- (f2cl-lib:fref d-%data% (1) ((1 3)) d-%offset%) + tau)) + (/ (f2cl-lib:fref z-%data% (2) ((1 3)) z-%offset%) + (- (f2cl-lib:fref d-%data% (2) ((1 3)) d-%offset%) + tau)) + (/ (f2cl-lib:fref z-%data% (3) ((1 3)) z-%offset%) + (- (f2cl-lib:fref d-%data% (3) ((1 3)) d-%offset%) + tau)))) + (if (<= (abs finit) (abs temp)) (setf tau zero)))) + (cond + (first$ + (setf eps (dlamch "Epsilon")) + (setf base (dlamch "Base")) + (setf small1 + (expt base + (f2cl-lib:int + (/ + (/ (f2cl-lib:flog (dlamch "SafMin")) + (f2cl-lib:flog base)) + three)))) + (setf sminv1 (/ one small1)) + (setf small2 (* small1 small1)) + (setf sminv2 (* sminv1 sminv1)) + (setf first$ nil))) + (cond + (orgati + (setf temp + (min + (abs + (- (f2cl-lib:fref d-%data% (2) ((1 3)) d-%offset%) tau)) + (abs + (- (f2cl-lib:fref d-%data% (3) ((1 3)) d-%offset%) + tau))))) + (t + (setf temp + (min + (abs + (- (f2cl-lib:fref d-%data% (1) ((1 3)) d-%offset%) tau)) + (abs + (- (f2cl-lib:fref d-%data% (2) ((1 3)) d-%offset%) + tau)))))) + (setf scale nil) + (cond + ((<= temp small1) + (setf scale t) + (cond + ((<= temp small2) + (setf sclfac sminv2) + (setf sclinv small2)) + (t + (setf sclfac sminv1) + (setf sclinv small1))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i 3) nil) + (tagbody + (setf (f2cl-lib:fref dscale (i) ((1 3))) + (* (f2cl-lib:fref d-%data% (i) ((1 3)) d-%offset%) + sclfac)) + (setf (f2cl-lib:fref zscale (i) ((1 3))) + (* (f2cl-lib:fref z-%data% (i) ((1 3)) z-%offset%) + sclfac)))) + (setf tau (* tau sclfac))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i 3) nil) + (tagbody + (setf (f2cl-lib:fref dscale (i) ((1 3))) + (f2cl-lib:fref d-%data% (i) ((1 3)) d-%offset%)) + (setf (f2cl-lib:fref zscale (i) ((1 3))) + (f2cl-lib:fref z-%data% (i) ((1 3)) z-%offset%)))))) + (setf fc zero) + (setf df zero) + (setf ddf zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i 3) nil) + (tagbody + (setf temp (/ one (- (f2cl-lib:fref dscale (i) ((1 3))) tau))) + (setf temp1 (* (f2cl-lib:fref zscale (i) ((1 3))) temp)) + (setf temp2 (* temp1 temp)) + (setf temp3 (* temp2 temp)) + (setf fc (+ fc (/ temp1 (f2cl-lib:fref dscale (i) ((1 3)))))) + (setf df (+ df temp2)) + (setf ddf (+ ddf temp3)))) + (setf f (+ finit (* tau fc))) + (if (<= (abs f) zero) (go label60)) + (setf iter (f2cl-lib:int-add niter 1)) + (f2cl-lib:fdo (niter iter (f2cl-lib:int-add niter 1)) + ((> niter maxit) nil) + (tagbody + (cond + (orgati + (setf temp1 (- (f2cl-lib:fref dscale (2) ((1 3))) tau)) + (setf temp2 (- (f2cl-lib:fref dscale (3) ((1 3))) tau))) + (t + (setf temp1 (- (f2cl-lib:fref dscale (1) ((1 3))) tau)) + (setf temp2 (- (f2cl-lib:fref dscale (2) ((1 3))) tau)))) + (setf a (+ (* (+ temp1 temp2) f) (* (- temp1) temp2 df))) + (setf b (* temp1 temp2 f)) + (setf c (+ (- f (* (+ temp1 temp2) df)) (* temp1 temp2 ddf))) + (setf temp (max (abs a) (abs b) (abs c))) + (setf a (/ a temp)) + (setf b (/ b temp)) + (setf c (/ c temp)) + (cond + ((= c zero) + (setf eta (/ b a))) + ((<= a zero) + (setf eta + (/ + (- a + (f2cl-lib:fsqrt + (abs (+ (* a a) (* (- four) b c))))) + (* two c)))) + (t + (setf eta + (/ (* two b) + (+ a + (f2cl-lib:fsqrt + (abs (+ (* a a) (* (- four) b c))))))))) + (cond + ((>= (* f eta) zero) + (setf eta (/ (- f) df)))) + (setf temp (+ eta tau)) + (cond + (orgati + (if + (and (> eta zero) + (>= temp (f2cl-lib:fref dscale (3) ((1 3))))) + (setf eta (/ (- (f2cl-lib:fref dscale (3) ((1 3))) tau) two))) + (if + (and (< eta zero) + (<= temp (f2cl-lib:fref dscale (2) ((1 3))))) + (setf eta + (/ (- (f2cl-lib:fref dscale (2) ((1 3))) tau) two)))) + (t + (if + (and (> eta zero) + (>= temp (f2cl-lib:fref dscale (2) ((1 3))))) + (setf eta (/ (- (f2cl-lib:fref dscale (2) ((1 3))) tau) two))) + (if + (and (< eta zero) + (<= temp (f2cl-lib:fref dscale (1) ((1 3))))) + (setf eta + (/ (- (f2cl-lib:fref dscale (1) ((1 3))) tau) + two))))) + (setf tau (+ tau eta)) + (setf fc zero) + (setf erretm zero) + (setf df zero) + (setf ddf zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i 3) nil) + (tagbody + (setf temp + (/ one (- (f2cl-lib:fref dscale (i) ((1 3))) tau))) + (setf temp1 (* (f2cl-lib:fref zscale (i) ((1 3))) temp)) + (setf temp2 (* temp1 temp)) + (setf temp3 (* temp2 temp)) + (setf temp4 (/ temp1 (f2cl-lib:fref dscale (i) ((1 3))))) + (setf fc (+ fc temp4)) + (setf erretm (+ erretm (abs temp4))) + (setf df (+ df temp2)) + (setf ddf (+ ddf temp3)))) + (setf f (+ finit (* tau fc))) + (setf erretm + (+ (* eight (+ (abs finit) (* (abs tau) erretm))) + (* (abs tau) df))) + (if (<= (abs f) (* eps erretm)) (go label60)))) + (setf info 1) + label60 + (if scale (setf tau (* tau sclinv))) + end_label + (return (values nil nil nil nil nil nil tau info))))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dlaed6 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum (member t nil) + (double-float) (array double-float (3)) + (array double-float (3)) (double-float) (double-float) + fixnum) + :return-values '(nil nil nil nil nil nil fortran-to-lisp::tau + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlamch)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlaexc LAPACK} +\pagehead{dlaexc}{dlaexc} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0) (one 1.0) (ten 10.0) (ldd 4) (ldx 2)) + (declare (type (double-float 0.0 0.0) zero) + (type (double-float 1.0 1.0) one) + (type (double-float 10.0 10.0) ten) + (type (fixnum 4 4) ldd) + (type (fixnum 2 2) ldx)) + (defun dlaexc (wantq n t$ ldt q ldq j1 n1 n2 work info) + (declare (type (array double-float (*)) work q t$) + (type fixnum info n2 n1 j1 ldq ldt n) + (type (member t nil) wantq)) + (f2cl-lib:with-multi-array-data + ((t$ double-float t$-%data% t$-%offset%) + (q double-float q-%data% q-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((d + (make-array (the fixnum (reduce #'* (list ldd 4))) + :element-type 'double-float)) + (u (make-array 3 :element-type 'double-float)) + (u1 (make-array 3 :element-type 'double-float)) + (u2 (make-array 3 :element-type 'double-float)) + (x + (make-array (the fixnum (reduce #'* (list ldx 2))) + :element-type 'double-float)) + (cs 0.0) (dnorm 0.0) (eps 0.0) (scale 0.0) (smlnum 0.0) (sn 0.0) + (t11 0.0) (t22 0.0) (t33 0.0) (tau 0.0) (tau1 0.0) (tau2 0.0) + (temp 0.0) (thresh 0.0) (wi1 0.0) (wi2 0.0) (wr1 0.0) (wr2 0.0) + (xnorm 0.0) (ierr 0) (j2 0) (j3 0) (j4 0) (k 0) (nd 0)) + (declare (type (array double-float (3)) u u1 u2) + (type (array double-float (*)) d x) + (type (double-float) cs dnorm eps scale smlnum sn t11 t22 t33 + tau tau1 tau2 temp thresh wi1 wi2 wr1 wr2 + xnorm) + (type fixnum ierr j2 j3 j4 k nd)) + (setf info 0) + (if (or (= n 0) (= n1 0) (= n2 0)) (go end_label)) + (if (> (f2cl-lib:int-add j1 n1) n) (go end_label)) + (setf j2 (f2cl-lib:int-add j1 1)) + (setf j3 (f2cl-lib:int-add j1 2)) + (setf j4 (f2cl-lib:int-add j1 3)) + (cond + ((and (= n1 1) (= n2 1)) + (setf t11 + (f2cl-lib:fref t$-%data% + (j1 j1) + ((1 ldt) (1 *)) + t$-%offset%)) + (setf t22 + (f2cl-lib:fref t$-%data% + (j2 j2) + ((1 ldt) (1 *)) + t$-%offset%)) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlartg + (f2cl-lib:fref t$-%data% (j1 j2) ((1 ldt) (1 *)) t$-%offset%) + (- t22 t11) cs sn temp) + (declare (ignore var-0 var-1)) + (setf cs var-2) + (setf sn var-3) + (setf temp var-4)) + (if (<= j3 n) + (drot (f2cl-lib:int-sub n j1 1) + (f2cl-lib:array-slice t$ double-float (j1 j3) ((1 ldt) (1 *))) + ldt + (f2cl-lib:array-slice t$ double-float (j2 j3) ((1 ldt) (1 *))) + ldt cs sn)) + (drot (f2cl-lib:int-sub j1 1) + (f2cl-lib:array-slice t$ double-float (1 j1) ((1 ldt) (1 *))) 1 + (f2cl-lib:array-slice t$ double-float (1 j2) ((1 ldt) (1 *))) 1 cs + sn) + (setf (f2cl-lib:fref t$-%data% (j1 j1) ((1 ldt) (1 *)) t$-%offset%) + t22) + (setf (f2cl-lib:fref t$-%data% (j2 j2) ((1 ldt) (1 *)) t$-%offset%) + t11) + (cond + (wantq + (drot n + (f2cl-lib:array-slice q double-float (1 j1) ((1 ldq) (1 *))) 1 + (f2cl-lib:array-slice q double-float (1 j2) ((1 ldq) (1 *))) 1 + cs sn)))) + (t + (tagbody + (setf nd (f2cl-lib:int-add n1 n2)) + (dlacpy "Full" nd nd + (f2cl-lib:array-slice t$ double-float (j1 j1) ((1 ldt) (1 *))) + ldt d ldd) + (setf dnorm (dlange "Max" nd nd d ldd work)) + (setf eps (dlamch "P")) + (setf smlnum (/ (dlamch "S") eps)) + (setf thresh (max (* ten eps dnorm) smlnum)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 + var-10 var-11 var-12 var-13 var-14 var-15) + (dlasy2 nil nil -1 n1 n2 d ldd + (f2cl-lib:array-slice d + double-float + ((+ n1 1) (f2cl-lib:int-add n1 1)) + ((1 ldd) (1 4))) + ldd + (f2cl-lib:array-slice d + double-float + (1 (f2cl-lib:int-add n1 1)) + ((1 ldd) (1 4))) + ldd scale x ldx xnorm ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8 var-9 var-10 var-12 var-13)) + (setf scale var-11) + (setf xnorm var-14) + (setf ierr var-15)) + (setf k (f2cl-lib:int-sub (f2cl-lib:int-add n1 n1 n2) 3)) + (f2cl-lib:computed-goto (label10 label20 label30) k) + label10 + (setf (f2cl-lib:fref u (1) ((1 3))) scale) + (setf (f2cl-lib:fref u (2) ((1 3))) + (f2cl-lib:fref x (1 1) ((1 ldx) (1 2)))) + (setf (f2cl-lib:fref u (3) ((1 3))) + (f2cl-lib:fref x (1 2) ((1 ldx) (1 2)))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlarfg 3 (f2cl-lib:fref u (3) ((1 3))) u 1 tau) + (declare (ignore var-0 var-2 var-3)) + (setf (f2cl-lib:fref u (3) ((1 3))) var-1) + (setf tau var-4)) + (setf (f2cl-lib:fref u (3) ((1 3))) one) + (setf t11 + (f2cl-lib:fref t$-%data% + (j1 j1) + ((1 ldt) (1 *)) + t$-%offset%)) + (dlarfx "L" 3 3 u tau d ldd work) + (dlarfx "R" 3 3 u tau d ldd work) + (if + (> + (max (abs (f2cl-lib:fref d (3 1) ((1 ldd) (1 4)))) + (abs (f2cl-lib:fref d (3 2) ((1 ldd) (1 4)))) + (abs (- (f2cl-lib:fref d (3 3) ((1 ldd) (1 4))) t11))) + thresh) + (go label50)) + (dlarfx "L" 3 (f2cl-lib:int-add (f2cl-lib:int-sub n j1) 1) u tau + (f2cl-lib:array-slice t$ double-float (j1 j1) ((1 ldt) (1 *))) + ldt work) + (dlarfx "R" j2 3 u tau + (f2cl-lib:array-slice t$ double-float (1 j1) ((1 ldt) (1 *))) ldt + work) + (setf (f2cl-lib:fref t$-%data% + (j3 j1) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (setf (f2cl-lib:fref t$-%data% + (j3 j2) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (setf (f2cl-lib:fref t$-%data% + (j3 j3) + ((1 ldt) (1 *)) + t$-%offset%) + t11) + (cond + (wantq + (dlarfx "R" n 3 u tau + (f2cl-lib:array-slice q double-float (1 j1) ((1 ldq) (1 *))) + ldq work))) + (go label40) + label20 + (setf (f2cl-lib:fref u (1) ((1 3))) + (- (f2cl-lib:fref x (1 1) ((1 ldx) (1 2))))) + (setf (f2cl-lib:fref u (2) ((1 3))) + (- (f2cl-lib:fref x (2 1) ((1 ldx) (1 2))))) + (setf (f2cl-lib:fref u (3) ((1 3))) scale) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlarfg 3 (f2cl-lib:fref u (1) ((1 3))) + (f2cl-lib:array-slice u double-float (2) ((1 3))) 1 tau) + (declare (ignore var-0 var-2 var-3)) + (setf (f2cl-lib:fref u (1) ((1 3))) var-1) + (setf tau var-4)) + (setf (f2cl-lib:fref u (1) ((1 3))) one) + (setf t33 + (f2cl-lib:fref t$-%data% + (j3 j3) + ((1 ldt) (1 *)) + t$-%offset%)) + (dlarfx "L" 3 3 u tau d ldd work) + (dlarfx "R" 3 3 u tau d ldd work) + (if + (> + (max (abs (f2cl-lib:fref d (2 1) ((1 ldd) (1 4)))) + (abs (f2cl-lib:fref d (3 1) ((1 ldd) (1 4)))) + (abs (- (f2cl-lib:fref d (1 1) ((1 ldd) (1 4))) t33))) + thresh) + (go label50)) + (dlarfx "R" j3 3 u tau + (f2cl-lib:array-slice t$ double-float (1 j1) ((1 ldt) (1 *))) ldt + work) + (dlarfx "L" 3 (f2cl-lib:int-sub n j1) u tau + (f2cl-lib:array-slice t$ double-float (j1 j2) ((1 ldt) (1 *))) + ldt work) + (setf (f2cl-lib:fref t$-%data% + (j1 j1) + ((1 ldt) (1 *)) + t$-%offset%) + t33) + (setf (f2cl-lib:fref t$-%data% + (j2 j1) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (setf (f2cl-lib:fref t$-%data% + (j3 j1) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (cond + (wantq + (dlarfx "R" n 3 u tau + (f2cl-lib:array-slice q double-float (1 j1) ((1 ldq) (1 *))) + ldq work))) + (go label40) + label30 + (setf (f2cl-lib:fref u1 (1) ((1 3))) + (- (f2cl-lib:fref x (1 1) ((1 ldx) (1 2))))) + (setf (f2cl-lib:fref u1 (2) ((1 3))) + (- (f2cl-lib:fref x (2 1) ((1 ldx) (1 2))))) + (setf (f2cl-lib:fref u1 (3) ((1 3))) scale) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlarfg 3 (f2cl-lib:fref u1 (1) ((1 3))) + (f2cl-lib:array-slice u1 double-float (2) ((1 3))) 1 tau1) + (declare (ignore var-0 var-2 var-3)) + (setf (f2cl-lib:fref u1 (1) ((1 3))) var-1) + (setf tau1 var-4)) + (setf (f2cl-lib:fref u1 (1) ((1 3))) one) + (setf temp + (* (- tau1) + (+ (f2cl-lib:fref x (1 2) ((1 ldx) (1 2))) + (* (f2cl-lib:fref u1 (2) ((1 3))) + (f2cl-lib:fref x (2 2) ((1 ldx) (1 2))))))) + (setf (f2cl-lib:fref u2 (1) ((1 3))) + (- (* (- temp) (f2cl-lib:fref u1 (2) ((1 3)))) + (f2cl-lib:fref x (2 2) ((1 ldx) (1 2))))) + (setf (f2cl-lib:fref u2 (2) ((1 3))) + (* (- temp) (f2cl-lib:fref u1 (3) ((1 3))))) + (setf (f2cl-lib:fref u2 (3) ((1 3))) scale) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlarfg 3 (f2cl-lib:fref u2 (1) ((1 3))) + (f2cl-lib:array-slice u2 double-float (2) ((1 3))) 1 tau2) + (declare (ignore var-0 var-2 var-3)) + (setf (f2cl-lib:fref u2 (1) ((1 3))) var-1) + (setf tau2 var-4)) + (setf (f2cl-lib:fref u2 (1) ((1 3))) one) + (dlarfx "L" 3 4 u1 tau1 d ldd work) + (dlarfx "R" 4 3 u1 tau1 d ldd work) + (dlarfx "L" 3 4 u2 tau2 + (f2cl-lib:array-slice d double-float (2 1) ((1 ldd) (1 4))) ldd + work) + (dlarfx "R" 4 3 u2 tau2 + (f2cl-lib:array-slice d double-float (1 2) ((1 ldd) (1 4))) ldd + work) + (if + (> + (max (abs (f2cl-lib:fref d (3 1) ((1 ldd) (1 4)))) + (abs (f2cl-lib:fref d (3 2) ((1 ldd) (1 4)))) + (abs (f2cl-lib:fref d (4 1) ((1 ldd) (1 4)))) + (abs (f2cl-lib:fref d (4 2) ((1 ldd) (1 4))))) + thresh) + (go label50)) + (dlarfx "L" 3 (f2cl-lib:int-add (f2cl-lib:int-sub n j1) 1) u1 tau1 + (f2cl-lib:array-slice t$ double-float (j1 j1) ((1 ldt) (1 *))) + ldt work) + (dlarfx "R" j4 3 u1 tau1 + (f2cl-lib:array-slice t$ double-float (1 j1) ((1 ldt) (1 *))) ldt + work) + (dlarfx "L" 3 (f2cl-lib:int-add (f2cl-lib:int-sub n j1) 1) u2 tau2 + (f2cl-lib:array-slice t$ double-float (j2 j1) ((1 ldt) (1 *))) + ldt work) + (dlarfx "R" j4 3 u2 tau2 + (f2cl-lib:array-slice t$ double-float (1 j2) ((1 ldt) (1 *))) ldt + work) + (setf (f2cl-lib:fref t$-%data% + (j3 j1) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (setf (f2cl-lib:fref t$-%data% + (j3 j2) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (setf (f2cl-lib:fref t$-%data% + (j4 j1) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (setf (f2cl-lib:fref t$-%data% + (j4 j2) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (cond + (wantq + (dlarfx "R" n 3 u1 tau1 + (f2cl-lib:array-slice q double-float (1 j1) ((1 ldq) (1 *))) + ldq work) + (dlarfx "R" n 3 u2 tau2 + (f2cl-lib:array-slice q double-float (1 j2) ((1 ldq) (1 *))) + ldq work))) + label40 + (cond + ((= n2 2) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dlanv2 + (f2cl-lib:fref t$-%data% + (j1 j1) + ((1 ldt) (1 *)) + t$-%offset%) + (f2cl-lib:fref t$-%data% + (j1 j2) + ((1 ldt) (1 *)) + t$-%offset%) + (f2cl-lib:fref t$-%data% + (j2 j1) + ((1 ldt) (1 *)) + t$-%offset%) + (f2cl-lib:fref t$-%data% + (j2 j2) + ((1 ldt) (1 *)) + t$-%offset%) + wr1 wi1 wr2 wi2 cs sn) + (declare (ignore)) + (setf (f2cl-lib:fref t$-%data% + (j1 j1) + ((1 ldt) (1 *)) + t$-%offset%) + var-0) + (setf (f2cl-lib:fref t$-%data% + (j1 j2) + ((1 ldt) (1 *)) + t$-%offset%) + var-1) + (setf (f2cl-lib:fref t$-%data% + (j2 j1) + ((1 ldt) (1 *)) + t$-%offset%) + var-2) + (setf (f2cl-lib:fref t$-%data% + (j2 j2) + ((1 ldt) (1 *)) + t$-%offset%) + var-3) + (setf wr1 var-4) + (setf wi1 var-5) + (setf wr2 var-6) + (setf wi2 var-7) + (setf cs var-8) + (setf sn var-9)) + (drot (f2cl-lib:int-sub n j1 1) + (f2cl-lib:array-slice t$ + double-float + (j1 (f2cl-lib:int-add j1 2)) + ((1 ldt) (1 *))) + ldt + (f2cl-lib:array-slice t$ + double-float + (j2 (f2cl-lib:int-add j1 2)) + ((1 ldt) (1 *))) + ldt cs sn) + (drot (f2cl-lib:int-sub j1 1) + (f2cl-lib:array-slice t$ double-float (1 j1) ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice t$ double-float (1 j2) ((1 ldt) (1 *))) + 1 cs sn) + (if wantq + (drot n + (f2cl-lib:array-slice q + double-float + (1 j1) + ((1 ldq) (1 *))) + 1 + (f2cl-lib:array-slice q + double-float + (1 j2) + ((1 ldq) (1 *))) + 1 cs sn)))) + (cond + ((= n1 2) + (setf j3 (f2cl-lib:int-add j1 n2)) + (setf j4 (f2cl-lib:int-add j3 1)) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dlanv2 + (f2cl-lib:fref t$-%data% + (j3 j3) + ((1 ldt) (1 *)) + t$-%offset%) + (f2cl-lib:fref t$-%data% + (j3 j4) + ((1 ldt) (1 *)) + t$-%offset%) + (f2cl-lib:fref t$-%data% + (j4 j3) + ((1 ldt) (1 *)) + t$-%offset%) + (f2cl-lib:fref t$-%data% + (j4 j4) + ((1 ldt) (1 *)) + t$-%offset%) + wr1 wi1 wr2 wi2 cs sn) + (declare (ignore)) + (setf (f2cl-lib:fref t$-%data% + (j3 j3) + ((1 ldt) (1 *)) + t$-%offset%) + var-0) + (setf (f2cl-lib:fref t$-%data% + (j3 j4) + ((1 ldt) (1 *)) + t$-%offset%) + var-1) + (setf (f2cl-lib:fref t$-%data% + (j4 j3) + ((1 ldt) (1 *)) + t$-%offset%) + var-2) + (setf (f2cl-lib:fref t$-%data% + (j4 j4) + ((1 ldt) (1 *)) + t$-%offset%) + var-3) + (setf wr1 var-4) + (setf wi1 var-5) + (setf wr2 var-6) + (setf wi2 var-7) + (setf cs var-8) + (setf sn var-9)) + (if (<= (f2cl-lib:int-add j3 2) n) + (drot (f2cl-lib:int-sub n j3 1) + (f2cl-lib:array-slice t$ + double-float + (j3 (f2cl-lib:int-add j3 2)) + ((1 ldt) (1 *))) + ldt + (f2cl-lib:array-slice t$ + double-float + (j4 (f2cl-lib:int-add j3 2)) + ((1 ldt) (1 *))) + ldt cs sn)) + (drot (f2cl-lib:int-sub j3 1) + (f2cl-lib:array-slice t$ double-float (1 j3) ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice t$ double-float (1 j4) ((1 ldt) (1 *))) + 1 cs sn) + (if wantq + (drot n + (f2cl-lib:array-slice q + double-float + (1 j3) + ((1 ldq) (1 *))) + 1 + (f2cl-lib:array-slice q + double-float + (1 j4) + ((1 ldq) (1 *))) + 1 cs sn))))))) + (go end_label) + label50 + (setf info 1) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dlaexc + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((member t nil) fixnum + (array double-float (*)) fixnum + (array double-float (*)) fixnum + fixnum fixnum + fixnum (array double-float (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlanv2 fortran-to-lisp::dlarfx + fortran-to-lisp::dlarfg fortran-to-lisp::dlasy2 + fortran-to-lisp::dlamch fortran-to-lisp::dlange + fortran-to-lisp::dlacpy fortran-to-lisp::drot + fortran-to-lisp::dlartg)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlahqr LAPACK} +\pagehead{dlahqr}{dlahqr} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(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) + (type (double-float 1.0 1.0) one) + (type (double-float 0.5 0.5) half) + (type (double-float 0.75 0.75) dat1) + (type (double-float) dat2)) + (defun dlahqr (wantt wantz n ilo ihi h ldh wr wi iloz ihiz z ldz info) + (declare (type (array double-float (*)) z wi wr h) + (type fixnum info ldz ihiz iloz ldh ihi ilo n) + (type (member t nil) wantz wantt)) + (f2cl-lib:with-multi-array-data + ((h double-float h-%data% h-%offset%) + (wr double-float wr-%data% wr-%offset%) + (wi double-float wi-%data% wi-%offset%) + (z double-float z-%data% z-%offset%)) + (prog ((v (make-array 3 :element-type 'double-float)) + (work (make-array 1 :element-type 'double-float)) (ave 0.0) + (cs 0.0) (disc 0.0) (h00 0.0) (h10 0.0) (h11 0.0) (h12 0.0) + (h21 0.0) (h22 0.0) (h33 0.0) (h33s 0.0) (h43h34 0.0) (h44 0.0) + (h44s 0.0) (ovfl 0.0) (s 0.0) (smlnum 0.0) (sn 0.0) (sum 0.0) + (t1 0.0) (t2 0.0) (t3 0.0) (tst1 0.0) (ulp 0.0) (unfl 0.0) + (v1 0.0) (v2 0.0) (v3 0.0) (i 0) (i1 0) (i2 0) (itn 0) (its 0) + (j 0) (k 0) (l 0) (m 0) (nh 0) (nr 0) (nz 0)) + (declare (type (array double-float (3)) v) + (type (array double-float (1)) work) + (type (double-float) 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) + (type fixnum i i1 i2 itn its j k l m nh nr nz)) + (setf info 0) + (if (= n 0) (go end_label)) + (cond + ((= ilo ihi) + (setf (f2cl-lib:fref wr-%data% (ilo) ((1 *)) wr-%offset%) + (f2cl-lib:fref h-%data% + (ilo ilo) + ((1 ldh) (1 *)) + h-%offset%)) + (setf (f2cl-lib:fref wi-%data% (ilo) ((1 *)) wi-%offset%) zero) + (go end_label))) + (setf nh (f2cl-lib:int-add (f2cl-lib:int-sub ihi ilo) 1)) + (setf nz (f2cl-lib:int-add (f2cl-lib:int-sub ihiz iloz) 1)) + (setf unfl (dlamch "Safe minimum")) + (setf ovfl (/ one unfl)) + (multiple-value-bind (var-0 var-1) + (dlabad unfl ovfl) + (declare (ignore)) + (setf unfl var-0) + (setf ovfl var-1)) + (setf ulp (dlamch "Precision")) + (setf smlnum (* unfl (/ nh ulp))) + (cond + (wantt + (setf i1 1) + (setf i2 n))) + (setf itn (f2cl-lib:int-mul 30 nh)) + (setf i ihi) + label10 + (setf l ilo) + (if (< i ilo) (go end_label)) + (f2cl-lib:fdo (its 0 (f2cl-lib:int-add its 1)) + ((> its itn) nil) + (tagbody + (f2cl-lib:fdo (k i (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k (f2cl-lib:int-add l 1)) nil) + (tagbody + (setf tst1 + (+ + (abs + (f2cl-lib:fref h-%data% + ((f2cl-lib:int-sub k 1) + (f2cl-lib:int-sub k 1)) + ((1 ldh) (1 *)) + h-%offset%)) + (abs + (f2cl-lib:fref h-%data% + (k k) + ((1 ldh) (1 *)) + h-%offset%)))) + (if (= tst1 zero) + (setf tst1 + (dlanhs "1" + (f2cl-lib:int-add (f2cl-lib:int-sub i l) 1) + (f2cl-lib:array-slice h + double-float + (l l) + ((1 ldh) (1 *))) + ldh work))) + (if + (<= + (abs + (f2cl-lib:fref h-%data% + (k (f2cl-lib:int-sub k 1)) + ((1 ldh) (1 *)) + h-%offset%)) + (max (* ulp tst1) smlnum)) + (go label30)))) + label30 + (setf l k) + (cond + ((> l ilo) + (setf (f2cl-lib:fref h-%data% + (l (f2cl-lib:int-sub l 1)) + ((1 ldh) (1 *)) + h-%offset%) + zero))) + (if (>= l (f2cl-lib:int-sub i 1)) (go label140)) + (cond + ((not wantt) + (setf i1 l) + (setf i2 i))) + (cond + ((or (= its 10) (= its 20)) + (setf s + (+ + (abs + (f2cl-lib:fref h-%data% + (i (f2cl-lib:int-sub i 1)) + ((1 ldh) (1 *)) + h-%offset%)) + (abs + (f2cl-lib:fref h-%data% + ((f2cl-lib:int-sub i 1) + (f2cl-lib:int-sub i 2)) + ((1 ldh) (1 *)) + h-%offset%)))) + (setf h44 + (+ (* dat1 s) + (f2cl-lib:fref h-%data% + (i i) + ((1 ldh) (1 *)) + h-%offset%))) + (setf h33 h44) + (setf h43h34 (* dat2 s s))) + (t + (setf h44 + (f2cl-lib:fref h-%data% + (i i) + ((1 ldh) (1 *)) + h-%offset%)) + (setf h33 + (f2cl-lib:fref h-%data% + ((f2cl-lib:int-sub i 1) + (f2cl-lib:int-sub i 1)) + ((1 ldh) (1 *)) + h-%offset%)) + (setf h43h34 + (* + (f2cl-lib:fref h-%data% + (i (f2cl-lib:int-sub i 1)) + ((1 ldh) (1 *)) + h-%offset%) + (f2cl-lib:fref h-%data% + ((f2cl-lib:int-sub i 1) i) + ((1 ldh) (1 *)) + h-%offset%))) + (setf s + (* + (f2cl-lib:fref h-%data% + ((f2cl-lib:int-sub i 1) + (f2cl-lib:int-sub i 2)) + ((1 ldh) (1 *)) + h-%offset%) + (f2cl-lib:fref h-%data% + ((f2cl-lib:int-sub i 1) + (f2cl-lib:int-sub i 2)) + ((1 ldh) (1 *)) + h-%offset%))) + (setf disc (* (- h33 h44) half)) + (setf disc (+ (* disc disc) h43h34)) + (cond + ((> disc zero) + (setf disc (f2cl-lib:fsqrt disc)) + (setf ave (* half (+ h33 h44))) + (cond + ((> (+ (abs h33) (- (abs h44))) zero) + (setf h33 (- (* h33 h44) h43h34)) + (setf h44 (/ h33 (+ (f2cl-lib:sign disc ave) ave)))) + (t + (setf h44 (+ (f2cl-lib:sign disc ave) ave)))) + (setf h33 h44) + (setf h43h34 zero))))) + (f2cl-lib:fdo (m (f2cl-lib:int-add i (f2cl-lib:int-sub 2)) + (f2cl-lib:int-add m (f2cl-lib:int-sub 1))) + ((> m l) nil) + (tagbody + (setf h11 + (f2cl-lib:fref h-%data% + (m m) + ((1 ldh) (1 *)) + h-%offset%)) + (setf h22 + (f2cl-lib:fref h-%data% + ((f2cl-lib:int-add m 1) + (f2cl-lib:int-add m 1)) + ((1 ldh) (1 *)) + h-%offset%)) + (setf h21 + (f2cl-lib:fref h-%data% + ((f2cl-lib:int-add m 1) m) + ((1 ldh) (1 *)) + h-%offset%)) + (setf h12 + (f2cl-lib:fref h-%data% + (m (f2cl-lib:int-add m 1)) + ((1 ldh) (1 *)) + h-%offset%)) + (setf h44s (- h44 h11)) + (setf h33s (- h33 h11)) + (setf v1 (+ (/ (- (* h33s h44s) h43h34) h21) h12)) + (setf v2 (- h22 h11 h33s h44s)) + (setf v3 + (f2cl-lib:fref h-%data% + ((f2cl-lib:int-add m 2) + (f2cl-lib:int-add m 1)) + ((1 ldh) (1 *)) + h-%offset%)) + (setf s (+ (abs v1) (abs v2) (abs v3))) + (setf v1 (/ v1 s)) + (setf v2 (/ v2 s)) + (setf v3 (/ v3 s)) + (setf (f2cl-lib:fref v (1) ((1 3))) v1) + (setf (f2cl-lib:fref v (2) ((1 3))) v2) + (setf (f2cl-lib:fref v (3) ((1 3))) v3) + (if (= m l) (go label50)) + (setf h00 + (f2cl-lib:fref h-%data% + ((f2cl-lib:int-sub m 1) + (f2cl-lib:int-sub m 1)) + ((1 ldh) (1 *)) + h-%offset%)) + (setf h10 + (f2cl-lib:fref h-%data% + (m (f2cl-lib:int-sub m 1)) + ((1 ldh) (1 *)) + h-%offset%)) + (setf tst1 (* (abs v1) (+ (abs h00) (abs h11) (abs h22)))) + (if (<= (* (abs h10) (+ (abs v2) (abs v3))) (* ulp tst1)) + (go label50)))) + label50 + (f2cl-lib:fdo (k m (f2cl-lib:int-add k 1)) + ((> k (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) nil) + (tagbody + (setf nr + (min (the fixnum 3) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-sub i k) + 1)))) + (if (> k m) + (dcopy nr + (f2cl-lib:array-slice h + double-float + (k (f2cl-lib:int-sub k 1)) + ((1 ldh) (1 *))) + 1 v 1)) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlarfg nr (f2cl-lib:fref v (1) ((1 3))) + (f2cl-lib:array-slice v double-float (2) ((1 3))) 1 t1) + (declare (ignore var-0 var-2 var-3)) + (setf (f2cl-lib:fref v (1) ((1 3))) var-1) + (setf t1 var-4)) + (cond + ((> k m) + (setf (f2cl-lib:fref h-%data% + (k (f2cl-lib:int-sub k 1)) + ((1 ldh) (1 *)) + h-%offset%) + (f2cl-lib:fref v (1) ((1 3)))) + (setf (f2cl-lib:fref h-%data% + ((f2cl-lib:int-add k 1) + (f2cl-lib:int-sub k 1)) + ((1 ldh) (1 *)) + h-%offset%) + zero) + (if (< k (f2cl-lib:int-sub i 1)) + (setf (f2cl-lib:fref h-%data% + ((f2cl-lib:int-add k 2) + (f2cl-lib:int-sub k 1)) + ((1 ldh) (1 *)) + h-%offset%) + zero))) + ((> m l) + (setf (f2cl-lib:fref h-%data% + (k (f2cl-lib:int-sub k 1)) + ((1 ldh) (1 *)) + h-%offset%) + (- + (f2cl-lib:fref h-%data% + (k (f2cl-lib:int-sub k 1)) + ((1 ldh) (1 *)) + h-%offset%))))) + (setf v2 (f2cl-lib:fref v (2) ((1 3)))) + (setf t2 (* t1 v2)) + (cond + ((= nr 3) + (setf v3 (f2cl-lib:fref v (3) ((1 3)))) + (setf t3 (* t1 v3)) + (f2cl-lib:fdo (j k (f2cl-lib:int-add j 1)) + ((> j i2) nil) + (tagbody + (setf sum + (+ + (f2cl-lib:fref h-%data% + (k j) + ((1 ldh) (1 *)) + h-%offset%) + (* v2 + (f2cl-lib:fref h-%data% + ((f2cl-lib:int-add k 1) j) + ((1 ldh) (1 *)) + h-%offset%)) + (* v3 + (f2cl-lib:fref h-%data% + ((f2cl-lib:int-add k 2) j) + ((1 ldh) (1 *)) + h-%offset%)))) + (setf (f2cl-lib:fref h-%data% + (k j) + ((1 ldh) (1 *)) + h-%offset%) + (- + (f2cl-lib:fref h-%data% + (k j) + ((1 ldh) (1 *)) + h-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref h-%data% + ((f2cl-lib:int-add k 1) j) + ((1 ldh) (1 *)) + h-%offset%) + (- + (f2cl-lib:fref h-%data% + ((f2cl-lib:int-add k 1) j) + ((1 ldh) (1 *)) + h-%offset%) + (* sum t2))) + (setf (f2cl-lib:fref h-%data% + ((f2cl-lib:int-add k 2) j) + ((1 ldh) (1 *)) + h-%offset%) + (- + (f2cl-lib:fref h-%data% + ((f2cl-lib:int-add k 2) j) + ((1 ldh) (1 *)) + h-%offset%) + (* sum t3))))) + (f2cl-lib:fdo (j i1 (f2cl-lib:int-add j 1)) + ((> j + (min + (the fixnum + (f2cl-lib:int-add k 3)) + (the fixnum i))) + nil) + (tagbody + (setf sum + (+ + (f2cl-lib:fref h-%data% + (j k) + ((1 ldh) (1 *)) + h-%offset%) + (* v2 + (f2cl-lib:fref h-%data% + (j (f2cl-lib:int-add k 1)) + ((1 ldh) (1 *)) + h-%offset%)) + (* v3 + (f2cl-lib:fref h-%data% + (j (f2cl-lib:int-add k 2)) + ((1 ldh) (1 *)) + h-%offset%)))) + (setf (f2cl-lib:fref h-%data% + (j k) + ((1 ldh) (1 *)) + h-%offset%) + (- + (f2cl-lib:fref h-%data% + (j k) + ((1 ldh) (1 *)) + h-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref h-%data% + (j (f2cl-lib:int-add k 1)) + ((1 ldh) (1 *)) + h-%offset%) + (- + (f2cl-lib:fref h-%data% + (j (f2cl-lib:int-add k 1)) + ((1 ldh) (1 *)) + h-%offset%) + (* sum t2))) + (setf (f2cl-lib:fref h-%data% + (j (f2cl-lib:int-add k 2)) + ((1 ldh) (1 *)) + h-%offset%) + (- + (f2cl-lib:fref h-%data% + (j (f2cl-lib:int-add k 2)) + ((1 ldh) (1 *)) + h-%offset%) + (* sum t3))))) + (cond + (wantz + (f2cl-lib:fdo (j iloz (f2cl-lib:int-add j 1)) + ((> j ihiz) nil) + (tagbody + (setf sum + (+ + (f2cl-lib:fref z-%data% + (j k) + ((1 ldz) (1 *)) + z-%offset%) + (* v2 + (f2cl-lib:fref z-%data% + (j (f2cl-lib:int-add k 1)) + ((1 ldz) (1 *)) + z-%offset%)) + (* v3 + (f2cl-lib:fref z-%data% + (j (f2cl-lib:int-add k 2)) + ((1 ldz) (1 *)) + z-%offset%)))) + (setf (f2cl-lib:fref z-%data% + (j k) + ((1 ldz) (1 *)) + z-%offset%) + (- + (f2cl-lib:fref z-%data% + (j k) + ((1 ldz) (1 *)) + z-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref z-%data% + (j (f2cl-lib:int-add k 1)) + ((1 ldz) (1 *)) + z-%offset%) + (- + (f2cl-lib:fref z-%data% + (j (f2cl-lib:int-add k 1)) + ((1 ldz) (1 *)) + z-%offset%) + (* sum t2))) + (setf (f2cl-lib:fref z-%data% + (j (f2cl-lib:int-add k 2)) + ((1 ldz) (1 *)) + z-%offset%) + (- + (f2cl-lib:fref z-%data% + (j (f2cl-lib:int-add k 2)) + ((1 ldz) (1 *)) + z-%offset%) + (* sum t3)))))))) + ((= nr 2) + (f2cl-lib:fdo (j k (f2cl-lib:int-add j 1)) + ((> j i2) nil) + (tagbody + (setf sum + (+ + (f2cl-lib:fref h-%data% + (k j) + ((1 ldh) (1 *)) + h-%offset%) + (* v2 + (f2cl-lib:fref h-%data% + ((f2cl-lib:int-add k 1) j) + ((1 ldh) (1 *)) + h-%offset%)))) + (setf (f2cl-lib:fref h-%data% + (k j) + ((1 ldh) (1 *)) + h-%offset%) + (- + (f2cl-lib:fref h-%data% + (k j) + ((1 ldh) (1 *)) + h-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref h-%data% + ((f2cl-lib:int-add k 1) j) + ((1 ldh) (1 *)) + h-%offset%) + (- + (f2cl-lib:fref h-%data% + ((f2cl-lib:int-add k 1) j) + ((1 ldh) (1 *)) + h-%offset%) + (* sum t2))))) + (f2cl-lib:fdo (j i1 (f2cl-lib:int-add j 1)) + ((> j i) nil) + (tagbody + (setf sum + (+ + (f2cl-lib:fref h-%data% + (j k) + ((1 ldh) (1 *)) + h-%offset%) + (* v2 + (f2cl-lib:fref h-%data% + (j (f2cl-lib:int-add k 1)) + ((1 ldh) (1 *)) + h-%offset%)))) + (setf (f2cl-lib:fref h-%data% + (j k) + ((1 ldh) (1 *)) + h-%offset%) + (- + (f2cl-lib:fref h-%data% + (j k) + ((1 ldh) (1 *)) + h-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref h-%data% + (j (f2cl-lib:int-add k 1)) + ((1 ldh) (1 *)) + h-%offset%) + (- + (f2cl-lib:fref h-%data% + (j (f2cl-lib:int-add k 1)) + ((1 ldh) (1 *)) + h-%offset%) + (* sum t2))))) + (cond + (wantz + (f2cl-lib:fdo (j iloz (f2cl-lib:int-add j 1)) + ((> j ihiz) nil) + (tagbody + (setf sum + (+ + (f2cl-lib:fref z-%data% + (j k) + ((1 ldz) (1 *)) + z-%offset%) + (* v2 + (f2cl-lib:fref z-%data% + (j (f2cl-lib:int-add k 1)) + ((1 ldz) (1 *)) + z-%offset%)))) + (setf (f2cl-lib:fref z-%data% + (j k) + ((1 ldz) (1 *)) + z-%offset%) + (- + (f2cl-lib:fref z-%data% + (j k) + ((1 ldz) (1 *)) + z-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref z-%data% + (j (f2cl-lib:int-add k 1)) + ((1 ldz) (1 *)) + z-%offset%) + (- + (f2cl-lib:fref z-%data% + (j (f2cl-lib:int-add k 1)) + ((1 ldz) (1 *)) + z-%offset%) + (* sum t2))))))))))))) + (setf info i) + (go end_label) + label140 + (cond + ((= l i) + (setf (f2cl-lib:fref wr-%data% (i) ((1 *)) wr-%offset%) + (f2cl-lib:fref h-%data% (i i) ((1 ldh) (1 *)) h-%offset%)) + (setf (f2cl-lib:fref wi-%data% (i) ((1 *)) wi-%offset%) zero)) + ((= l (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dlanv2 + (f2cl-lib:fref h-%data% + ((f2cl-lib:int-sub i 1) (f2cl-lib:int-sub i 1)) + ((1 ldh) (1 *)) + h-%offset%) + (f2cl-lib:fref h-%data% + ((f2cl-lib:int-sub i 1) i) + ((1 ldh) (1 *)) + h-%offset%) + (f2cl-lib:fref h-%data% + (i (f2cl-lib:int-sub i 1)) + ((1 ldh) (1 *)) + h-%offset%) + (f2cl-lib:fref h-%data% (i i) ((1 ldh) (1 *)) h-%offset%) + (f2cl-lib:fref wr-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + wr-%offset%) + (f2cl-lib:fref wi-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + wi-%offset%) + (f2cl-lib:fref wr-%data% (i) ((1 *)) wr-%offset%) + (f2cl-lib:fref wi-%data% (i) ((1 *)) wi-%offset%) cs sn) + (declare (ignore)) + (setf (f2cl-lib:fref h-%data% + ((f2cl-lib:int-sub i 1) + (f2cl-lib:int-sub i 1)) + ((1 ldh) (1 *)) + h-%offset%) + var-0) + (setf (f2cl-lib:fref h-%data% + ((f2cl-lib:int-sub i 1) i) + ((1 ldh) (1 *)) + h-%offset%) + var-1) + (setf (f2cl-lib:fref h-%data% + (i (f2cl-lib:int-sub i 1)) + ((1 ldh) (1 *)) + h-%offset%) + var-2) + (setf (f2cl-lib:fref h-%data% (i i) ((1 ldh) (1 *)) h-%offset%) + var-3) + (setf (f2cl-lib:fref wr-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + wr-%offset%) + var-4) + (setf (f2cl-lib:fref wi-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + wi-%offset%) + var-5) + (setf (f2cl-lib:fref wr-%data% (i) ((1 *)) wr-%offset%) var-6) + (setf (f2cl-lib:fref wi-%data% (i) ((1 *)) wi-%offset%) var-7) + (setf cs var-8) + (setf sn var-9)) + (cond + (wantt + (if (> i2 i) + (drot (f2cl-lib:int-sub i2 i) + (f2cl-lib:array-slice h + double-float + ((+ i (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i 1)) + ((1 ldh) (1 *))) + ldh + (f2cl-lib:array-slice h + double-float + (i (f2cl-lib:int-add i 1)) + ((1 ldh) (1 *))) + ldh cs sn)) + (drot (f2cl-lib:int-sub i i1 1) + (f2cl-lib:array-slice h + double-float + (i1 (f2cl-lib:int-sub i 1)) + ((1 ldh) (1 *))) + 1 (f2cl-lib:array-slice h double-float (i1 i) ((1 ldh) (1 *))) 1 + cs sn))) + (cond + (wantz + (drot nz + (f2cl-lib:array-slice z + double-float + (iloz (f2cl-lib:int-sub i 1)) + ((1 ldz) (1 *))) + 1 (f2cl-lib:array-slice z double-float (iloz i) ((1 ldz) (1 *))) + 1 cs sn))))) + (setf itn (f2cl-lib:int-sub itn its)) + (setf i (f2cl-lib:int-sub l 1)) + (go label10) + end_label + (return + (values nil nil nil nil nil nil nil nil nil nil nil nil nil info)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dlahqr + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((member t nil) (member t nil) + fixnum fixnum + fixnum (array double-float (*)) + fixnum (array double-float (*)) + (array double-float (*)) fixnum + fixnum (array double-float (*)) + fixnum + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::drot fortran-to-lisp::dlanv2 + fortran-to-lisp::dlarfg fortran-to-lisp::dcopy + fortran-to-lisp::dlanhs fortran-to-lisp::dlabad + fortran-to-lisp::dlamch)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlahrd LAPACK} +\pagehead{dlahrd}{dlahrd} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0) (one 1.0)) + (declare (type (double-float 0.0 0.0) zero) + (type (double-float 1.0 1.0) one)) + (defun dlahrd (n k nb a lda tau t$ ldt y ldy) + (declare (type (array double-float (*)) y t$ tau a) + (type fixnum ldy ldt lda nb k n)) + (f2cl-lib:with-multi-array-data + ((a double-float a-%data% a-%offset%) + (tau double-float tau-%data% tau-%offset%) + (t$ double-float t$-%data% t$-%offset%) + (y double-float y-%data% y-%offset%)) + (prog ((ei 0.0) (i 0)) + (declare (type (double-float) ei) (type fixnum i)) + (if (<= n 1) (go end_label)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i nb) nil) + (tagbody + (cond + ((> i 1) + (dgemv "No transpose" n (f2cl-lib:int-sub i 1) (- one) y ldy + (f2cl-lib:array-slice a + double-float + ((+ k i (f2cl-lib:int-sub 1)) 1) + ((1 lda) (1 *))) + lda one + (f2cl-lib:array-slice a double-float (1 i) ((1 lda) (1 *))) 1) + (dcopy (f2cl-lib:int-sub i 1) + (f2cl-lib:array-slice a + double-float + ((+ k 1) i) + ((1 lda) (1 *))) + 1 + (f2cl-lib:array-slice t$ double-float (1 nb) ((1 ldt) (1 nb))) + 1) + (dtrmv "Lower" "Transpose" "Unit" (f2cl-lib:int-sub i 1) + (f2cl-lib:array-slice a + double-float + ((+ k 1) 1) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice t$ double-float (1 nb) ((1 ldt) (1 nb))) + 1) + (dgemv "Transpose" (f2cl-lib:int-add (f2cl-lib:int-sub n k i) 1) + (f2cl-lib:int-sub i 1) one + (f2cl-lib:array-slice a + double-float + ((+ k i) 1) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice a + double-float + ((+ k i) i) + ((1 lda) (1 *))) + 1 one + (f2cl-lib:array-slice t$ double-float (1 nb) ((1 ldt) (1 nb))) + 1) + (dtrmv "Upper" "Transpose" "Non-unit" (f2cl-lib:int-sub i 1) t$ + ldt + (f2cl-lib:array-slice t$ double-float (1 nb) ((1 ldt) (1 nb))) + 1) + (dgemv "No transpose" + (f2cl-lib:int-add (f2cl-lib:int-sub n k i) 1) + (f2cl-lib:int-sub i 1) (- one) + (f2cl-lib:array-slice a + double-float + ((+ k i) 1) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice t$ double-float (1 nb) ((1 ldt) (1 nb))) + 1 one + (f2cl-lib:array-slice a + double-float + ((+ k i) i) + ((1 lda) (1 *))) + 1) + (dtrmv "Lower" "No transpose" "Unit" (f2cl-lib:int-sub i 1) + (f2cl-lib:array-slice a + double-float + ((+ k 1) 1) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice t$ double-float (1 nb) ((1 ldt) (1 nb))) + 1) + (daxpy (f2cl-lib:int-sub i 1) (- one) + (f2cl-lib:array-slice t$ double-float (1 nb) ((1 ldt) (1 nb))) + 1 + (f2cl-lib:array-slice a + double-float + ((+ k 1) i) + ((1 lda) (1 *))) + 1) + (setf (f2cl-lib:fref a-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-add k i) + 1) + (f2cl-lib:int-sub i 1)) + ((1 lda) (1 *)) + a-%offset%) + ei))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlarfg (f2cl-lib:int-add (f2cl-lib:int-sub n k i) 1) + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add k i) i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:array-slice a + double-float + ((min (f2cl-lib:int-add k i 1) n) i) + ((1 lda) (1 *))) + 1 (f2cl-lib:fref tau-%data% (i) ((1 nb)) tau-%offset%)) + (declare (ignore var-0 var-2 var-3)) + (setf (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add k i) i) + ((1 lda) (1 *)) + a-%offset%) + var-1) + (setf (f2cl-lib:fref tau-%data% (i) ((1 nb)) tau-%offset%) + var-4)) + (setf ei + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add k i) i) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add k i) i) + ((1 lda) (1 *)) + a-%offset%) + one) + (dgemv "No transpose" n + (f2cl-lib:int-add (f2cl-lib:int-sub n k i) 1) one + (f2cl-lib:array-slice a + double-float + (1 (f2cl-lib:int-add i 1)) + ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice a double-float ((+ k i) i) ((1 lda) (1 *))) + 1 zero + (f2cl-lib:array-slice y double-float (1 i) ((1 ldy) (1 nb))) 1) + (dgemv "Transpose" (f2cl-lib:int-add (f2cl-lib:int-sub n k i) 1) + (f2cl-lib:int-sub i 1) one + (f2cl-lib:array-slice a double-float ((+ k i) 1) ((1 lda) (1 *))) + lda + (f2cl-lib:array-slice a double-float ((+ k i) i) ((1 lda) (1 *))) + 1 zero + (f2cl-lib:array-slice t$ double-float (1 i) ((1 ldt) (1 nb))) 1) + (dgemv "No transpose" n (f2cl-lib:int-sub i 1) (- one) y ldy + (f2cl-lib:array-slice t$ double-float (1 i) ((1 ldt) (1 nb))) 1 + one (f2cl-lib:array-slice y double-float (1 i) ((1 ldy) (1 nb))) + 1) + (dscal n (f2cl-lib:fref tau-%data% (i) ((1 nb)) tau-%offset%) + (f2cl-lib:array-slice y double-float (1 i) ((1 ldy) (1 nb))) 1) + (dscal (f2cl-lib:int-sub i 1) + (- (f2cl-lib:fref tau-%data% (i) ((1 nb)) tau-%offset%)) + (f2cl-lib:array-slice t$ double-float (1 i) ((1 ldt) (1 nb))) 1) + (dtrmv "Upper" "No transpose" "Non-unit" (f2cl-lib:int-sub i 1) t$ + ldt (f2cl-lib:array-slice t$ double-float (1 i) ((1 ldt) (1 nb))) + 1) + (setf (f2cl-lib:fref t$-%data% (i i) ((1 ldt) (1 nb)) t$-%offset%) + (f2cl-lib:fref tau-%data% (i) ((1 nb)) tau-%offset%)))) + (setf (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add k nb) nb) + ((1 lda) (1 *)) + a-%offset%) + ei) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil)))))) + +(in-package #-gcl #:cl-user #+gcl "CL-USER") +#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf (gethash 'fortran-to-lisp::dlahrd + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + fixnum (array double-float (*)) + fixnum (array double-float (*)) + (array double-float (*)) fixnum + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::dscal fortran-to-lisp::dlarfg + fortran-to-lisp::daxpy fortran-to-lisp::dtrmv + fortran-to-lisp::dcopy fortran-to-lisp::dgemv)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlaln2 LAPACK} +\pagehead{dlaln2}{dlaln2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0) (one 1.0) (two 2.0)) + (declare (type (double-float 0.0 0.0) zero) + (type (double-float 1.0 1.0) one) + (type (double-float 2.0 2.0) two)) + (let ((zswap + (make-array 4 :element-type 't :initial-contents '(nil nil t t))) + (rswap + (make-array 4 :element-type 't :initial-contents '(nil t nil t))) + (ipivot + (make-array 16 + :element-type 'fixnum + :initial-contents '(1 2 3 4 2 1 4 3 3 4 1 2 4 3 2 1)))) + (declare (type (array fixnum (16)) ipivot) + (type (array (member t nil) (4)) rswap zswap)) + (defun dlaln2 + (ltrans na nw smin ca a lda d1 d2 b ldb$ wr wi x ldx scale xnorm + info) + (declare (type (array double-float (*)) x b a) + (type (double-float) xnorm scale wi wr d2 d1 ca smin) + (type fixnum info ldx ldb$ lda nw na) + (type (member t nil) ltrans)) + (f2cl-lib:with-multi-array-data + ((a double-float a-%data% a-%offset%) + (b double-float b-%data% b-%offset%) + (x double-float x-%data% x-%offset%)) + (prog ((ci (make-array 4 :element-type 'double-float)) + (civ (make-array 4 :element-type 'double-float)) + (cr (make-array 4 :element-type 'double-float)) + (crv (make-array 4 :element-type 'double-float)) (bbnd 0.0) + (bi1 0.0) (bi2 0.0) (bignum 0.0) (bnorm 0.0) (br1 0.0) (br2 0.0) + (ci21 0.0) (ci22 0.0) (cmax 0.0) (cnorm 0.0) (cr21 0.0) + (cr22 0.0) (csi 0.0) (csr 0.0) (li21 0.0) (lr21 0.0) (smini 0.0) + (smlnum 0.0) (temp 0.0) (u22abs 0.0) (ui11 0.0) (ui11r 0.0) + (ui12 0.0) (ui12s 0.0) (ui22 0.0) (ur11 0.0) (ur11r 0.0) + (ur12 0.0) (ur12s 0.0) (ur22 0.0) (xi1 0.0) (xi2 0.0) (xr1 0.0) + (xr2 0.0) (icmax 0) (j 0)) + (declare (type (array double-float (4)) ci civ cr crv) + (type (double-float) 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) + (type fixnum icmax j)) + (setf smlnum (* two (dlamch "Safe minimum"))) + (setf bignum (/ one smlnum)) + (setf smini (max smin smlnum)) + (setf info 0) + (setf scale one) + (cond + ((= na 1) + (cond + ((= nw 1) + (setf csr + (- + (* ca + (f2cl-lib:fref a-%data% + (1 1) + ((1 lda) (1 *)) + a-%offset%)) + (* wr d1))) + (setf cnorm (abs csr)) + (cond + ((< cnorm smini) + (setf csr smini) + (setf cnorm smini) + (setf info 1))) + (setf bnorm + (abs + (f2cl-lib:fref b-%data% + (1 1) + ((1 ldb$) (1 *)) + b-%offset%))) + (cond + ((and (< cnorm one) (> bnorm one)) + (if (> bnorm (* bignum cnorm)) (setf scale (/ one bnorm))))) + (setf (f2cl-lib:fref x-%data% (1 1) ((1 ldx) (1 *)) x-%offset%) + (/ + (* + (f2cl-lib:fref b-%data% + (1 1) + ((1 ldb$) (1 *)) + b-%offset%) + scale) + csr)) + (setf xnorm + (abs + (f2cl-lib:fref x-%data% + (1 1) + ((1 ldx) (1 *)) + x-%offset%)))) + (t + (setf csr + (- + (* ca + (f2cl-lib:fref a-%data% + (1 1) + ((1 lda) (1 *)) + a-%offset%)) + (* wr d1))) + (setf csi (* (- wi) d1)) + (setf cnorm (+ (abs csr) (abs csi))) + (cond + ((< cnorm smini) + (setf csr smini) + (setf csi zero) + (setf cnorm smini) + (setf info 1))) + (setf bnorm + (+ + (abs + (f2cl-lib:fref b-%data% + (1 1) + ((1 ldb$) (1 *)) + b-%offset%)) + (abs + (f2cl-lib:fref b-%data% + (1 2) + ((1 ldb$) (1 *)) + b-%offset%)))) + (cond + ((and (< cnorm one) (> bnorm one)) + (if (> bnorm (* bignum cnorm)) (setf scale (/ one bnorm))))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5) + (dladiv + (* scale + (f2cl-lib:fref b-%data% + (1 1) + ((1 ldb$) (1 *)) + b-%offset%)) + (* scale + (f2cl-lib:fref b-%data% + (1 2) + ((1 ldb$) (1 *)) + b-%offset%)) + csr csi + (f2cl-lib:fref x-%data% (1 1) ((1 ldx) (1 *)) x-%offset%) + (f2cl-lib:fref x-%data% (1 2) ((1 ldx) (1 *)) x-%offset%)) + (declare (ignore var-0 var-1 var-2 var-3)) + (setf (f2cl-lib:fref x-%data% + (1 1) + ((1 ldx) (1 *)) + x-%offset%) + var-4) + (setf (f2cl-lib:fref x-%data% + (1 2) + ((1 ldx) (1 *)) + x-%offset%) + var-5)) + (setf xnorm + (+ + (abs + (f2cl-lib:fref x-%data% + (1 1) + ((1 ldx) (1 *)) + x-%offset%)) + (abs + (f2cl-lib:fref x-%data% + (1 2) + ((1 ldx) (1 *)) + x-%offset%))))))) + (t + (setf (f2cl-lib:fref crv (1) ((1 4))) + (- + (* ca + (f2cl-lib:fref a-%data% + (1 1) + ((1 lda) (1 *)) + a-%offset%)) + (* wr d1))) + (setf (f2cl-lib:fref crv (4) ((1 4))) + (- + (* ca + (f2cl-lib:fref a-%data% + (2 2) + ((1 lda) (1 *)) + a-%offset%)) + (* wr d2))) + (cond + (ltrans + (setf (f2cl-lib:fref crv (3) ((1 4))) + (* ca + (f2cl-lib:fref a-%data% + (2 1) + ((1 lda) (1 *)) + a-%offset%))) + (setf (f2cl-lib:fref crv (2) ((1 4))) + (* ca + (f2cl-lib:fref a-%data% + (1 2) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf (f2cl-lib:fref crv (2) ((1 4))) + (* ca + (f2cl-lib:fref a-%data% + (2 1) + ((1 lda) (1 *)) + a-%offset%))) + (setf (f2cl-lib:fref crv (3) ((1 4))) + (* ca + (f2cl-lib:fref a-%data% + (1 2) + ((1 lda) (1 *)) + a-%offset%))))) + (cond + ((= nw 1) + (setf cmax zero) + (setf icmax 0) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j 4) nil) + (tagbody + (cond + ((> (abs (f2cl-lib:fref crv (j) ((1 4)))) cmax) + (setf cmax (abs (f2cl-lib:fref crv (j) ((1 4))))) + (setf icmax j))))) + (cond + ((< cmax smini) + (setf bnorm + (max + (abs + (f2cl-lib:fref b-%data% + (1 1) + ((1 ldb$) (1 *)) + b-%offset%)) + (abs + (f2cl-lib:fref b-%data% + (2 1) + ((1 ldb$) (1 *)) + b-%offset%)))) + (cond + ((and (< smini one) (> bnorm one)) + (if (> bnorm (* bignum smini)) + (setf scale (/ one bnorm))))) + (setf temp (/ scale smini)) + (setf (f2cl-lib:fref x-%data% + (1 1) + ((1 ldx) (1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (1 1) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf (f2cl-lib:fref x-%data% + (2 1) + ((1 ldx) (1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (2 1) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf xnorm (* temp bnorm)) + (setf info 1) + (go end_label))) + (setf ur11 (f2cl-lib:fref crv (icmax) ((1 4)))) + (setf cr21 + (f2cl-lib:fref crv + ((f2cl-lib:fref ipivot + (2 icmax) + ((1 4) (1 4)))) + ((1 4)))) + (setf ur12 + (f2cl-lib:fref crv + ((f2cl-lib:fref ipivot + (3 icmax) + ((1 4) (1 4)))) + ((1 4)))) + (setf cr22 + (f2cl-lib:fref crv + ((f2cl-lib:fref ipivot + (4 icmax) + ((1 4) (1 4)))) + ((1 4)))) + (setf ur11r (/ one ur11)) + (setf lr21 (* ur11r cr21)) + (setf ur22 (- cr22 (* ur12 lr21))) + (cond + ((< (abs ur22) smini) + (setf ur22 smini) + (setf info 1))) + (cond + ((f2cl-lib:fref rswap (icmax) ((1 4))) + (setf br1 + (f2cl-lib:fref b-%data% + (2 1) + ((1 ldb$) (1 *)) + b-%offset%)) + (setf br2 + (f2cl-lib:fref b-%data% + (1 1) + ((1 ldb$) (1 *)) + b-%offset%))) + (t + (setf br1 + (f2cl-lib:fref b-%data% + (1 1) + ((1 ldb$) (1 *)) + b-%offset%)) + (setf br2 + (f2cl-lib:fref b-%data% + (2 1) + ((1 ldb$) (1 *)) + b-%offset%)))) + (setf br2 (- br2 (* lr21 br1))) + (setf bbnd (max (abs (* br1 (* ur22 ur11r))) (abs br2))) + (cond + ((and (> bbnd one) (< (abs ur22) one)) + (if (>= bbnd (* bignum (abs ur22))) + (setf scale (/ one bbnd))))) + (setf xr2 (/ (* br2 scale) ur22)) + (setf xr1 (- (* scale br1 ur11r) (* xr2 (* ur11r ur12)))) + (cond + ((f2cl-lib:fref zswap (icmax) ((1 4))) + (setf (f2cl-lib:fref x-%data% + (1 1) + ((1 ldx) (1 *)) + x-%offset%) + xr2) + (setf (f2cl-lib:fref x-%data% + (2 1) + ((1 ldx) (1 *)) + x-%offset%) + xr1)) + (t + (setf (f2cl-lib:fref x-%data% + (1 1) + ((1 ldx) (1 *)) + x-%offset%) + xr1) + (setf (f2cl-lib:fref x-%data% + (2 1) + ((1 ldx) (1 *)) + x-%offset%) + xr2))) + (setf xnorm (max (abs xr1) (abs xr2))) + (cond + ((and (> xnorm one) (> cmax one)) + (cond + ((> xnorm (f2cl-lib:f2cl/ bignum cmax)) + (setf temp (/ cmax bignum)) + (setf (f2cl-lib:fref x-%data% + (1 1) + ((1 ldx) (1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref x-%data% + (1 1) + ((1 ldx) (1 *)) + x-%offset%))) + (setf (f2cl-lib:fref x-%data% + (2 1) + ((1 ldx) (1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref x-%data% + (2 1) + ((1 ldx) (1 *)) + x-%offset%))) + (setf xnorm (* temp xnorm)) + (setf scale (* temp scale))))))) + (t + (setf (f2cl-lib:fref civ (1) ((1 4))) (* (- wi) d1)) + (setf (f2cl-lib:fref civ (2) ((1 4))) zero) + (setf (f2cl-lib:fref civ (3) ((1 4))) zero) + (setf (f2cl-lib:fref civ (4) ((1 4))) (* (- wi) d2)) + (setf cmax zero) + (setf icmax 0) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j 4) nil) + (tagbody + (cond + ((> + (+ (abs (f2cl-lib:fref crv (j) ((1 4)))) + (abs (f2cl-lib:fref civ (j) ((1 4))))) + cmax) + (setf cmax + (+ (abs (f2cl-lib:fref crv (j) ((1 4)))) + (abs (f2cl-lib:fref civ (j) ((1 4)))))) + (setf icmax j))))) + (cond + ((< cmax smini) + (setf bnorm + (max + (+ + (abs + (f2cl-lib:fref b-%data% + (1 1) + ((1 ldb$) (1 *)) + b-%offset%)) + (abs + (f2cl-lib:fref b-%data% + (1 2) + ((1 ldb$) (1 *)) + b-%offset%))) + (+ + (abs + (f2cl-lib:fref b-%data% + (2 1) + ((1 ldb$) (1 *)) + b-%offset%)) + (abs + (f2cl-lib:fref b-%data% + (2 2) + ((1 ldb$) (1 *)) + b-%offset%))))) + (cond + ((and (< smini one) (> bnorm one)) + (if (> bnorm (* bignum smini)) + (setf scale (/ one bnorm))))) + (setf temp (/ scale smini)) + (setf (f2cl-lib:fref x-%data% + (1 1) + ((1 ldx) (1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (1 1) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf (f2cl-lib:fref x-%data% + (2 1) + ((1 ldx) (1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (2 1) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf (f2cl-lib:fref x-%data% + (1 2) + ((1 ldx) (1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (1 2) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf (f2cl-lib:fref x-%data% + (2 2) + ((1 ldx) (1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (2 2) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf xnorm (* temp bnorm)) + (setf info 1) + (go end_label))) + (setf ur11 (f2cl-lib:fref crv (icmax) ((1 4)))) + (setf ui11 (f2cl-lib:fref civ (icmax) ((1 4)))) + (setf cr21 + (f2cl-lib:fref crv + ((f2cl-lib:fref ipivot + (2 icmax) + ((1 4) (1 4)))) + ((1 4)))) + (setf ci21 + (f2cl-lib:fref civ + ((f2cl-lib:fref ipivot + (2 icmax) + ((1 4) (1 4)))) + ((1 4)))) + (setf ur12 + (f2cl-lib:fref crv + ((f2cl-lib:fref ipivot + (3 icmax) + ((1 4) (1 4)))) + ((1 4)))) + (setf ui12 + (f2cl-lib:fref civ + ((f2cl-lib:fref ipivot + (3 icmax) + ((1 4) (1 4)))) + ((1 4)))) + (setf cr22 + (f2cl-lib:fref crv + ((f2cl-lib:fref ipivot + (4 icmax) + ((1 4) (1 4)))) + ((1 4)))) + (setf ci22 + (f2cl-lib:fref civ + ((f2cl-lib:fref ipivot + (4 icmax) + ((1 4) (1 4)))) + ((1 4)))) + (cond + ((or (= icmax 1) (= icmax 4)) + (cond + ((> (abs ur11) (abs ui11)) + (setf temp (/ ui11 ur11)) + (setf ur11r (/ one (* ur11 (+ one (expt temp 2))))) + (setf ui11r (* (- temp) ur11r))) + (t + (setf temp (/ ur11 ui11)) + (setf ui11r (/ (- one) (* ui11 (+ one (expt temp 2))))) + (setf ur11r (* (- temp) ui11r)))) + (setf lr21 (* cr21 ur11r)) + (setf li21 (* cr21 ui11r)) + (setf ur12s (* ur12 ur11r)) + (setf ui12s (* ur12 ui11r)) + (setf ur22 (- cr22 (* ur12 lr21))) + (setf ui22 (- ci22 (* ur12 li21)))) + (t + (setf ur11r (/ one ur11)) + (setf ui11r zero) + (setf lr21 (* cr21 ur11r)) + (setf li21 (* ci21 ur11r)) + (setf ur12s (* ur12 ur11r)) + (setf ui12s (* ui12 ur11r)) + (setf ur22 (+ (- cr22 (* ur12 lr21)) (* ui12 li21))) + (setf ui22 (- (* (- ur12) li21) (* ui12 lr21))))) + (setf u22abs (+ (abs ur22) (abs ui22))) + (cond + ((< u22abs smini) + (setf ur22 smini) + (setf ui22 zero) + (setf info 1))) + (cond + ((f2cl-lib:fref rswap (icmax) ((1 4))) + (setf br2 + (f2cl-lib:fref b-%data% + (1 1) + ((1 ldb$) (1 *)) + b-%offset%)) + (setf br1 + (f2cl-lib:fref b-%data% + (2 1) + ((1 ldb$) (1 *)) + b-%offset%)) + (setf bi2 + (f2cl-lib:fref b-%data% + (1 2) + ((1 ldb$) (1 *)) + b-%offset%)) + (setf bi1 + (f2cl-lib:fref b-%data% + (2 2) + ((1 ldb$) (1 *)) + b-%offset%))) + (t + (setf br1 + (f2cl-lib:fref b-%data% + (1 1) + ((1 ldb$) (1 *)) + b-%offset%)) + (setf br2 + (f2cl-lib:fref b-%data% + (2 1) + ((1 ldb$) (1 *)) + b-%offset%)) + (setf bi1 + (f2cl-lib:fref b-%data% + (1 2) + ((1 ldb$) (1 *)) + b-%offset%)) + (setf bi2 + (f2cl-lib:fref b-%data% + (2 2) + ((1 ldb$) (1 *)) + b-%offset%)))) + (setf br2 (+ (- br2 (* lr21 br1)) (* li21 bi1))) + (setf bi2 (- bi2 (* li21 br1) (* lr21 bi1))) + (setf bbnd + (max + (* (+ (abs br1) (abs bi1)) + (* u22abs (+ (abs ur11r) (abs ui11r)))) + (+ (abs br2) (abs bi2)))) + (cond + ((and (> bbnd one) (< u22abs one)) + (cond + ((>= bbnd (* bignum u22abs)) + (setf scale (/ one bbnd)) + (setf br1 (* scale br1)) + (setf bi1 (* scale bi1)) + (setf br2 (* scale br2)) + (setf bi2 (* scale bi2)))))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5) + (dladiv br2 bi2 ur22 ui22 xr2 xi2) + (declare (ignore var-0 var-1 var-2 var-3)) + (setf xr2 var-4) + (setf xi2 var-5)) + (setf xr1 + (+ (- (* ur11r br1) (* ui11r bi1) (* ur12s xr2)) +