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)) + (* ui12s xi2))) + (setf xi1 + (- (+ (* ui11r br1) (* ur11r bi1)) + (* ui12s xr2) + (* ur12s xi2))) + (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) + (setf (f2cl-lib:fref x-%data% + (1 2) + ((1 ldx) (1 *)) + x-%offset%) + xi2) + (setf (f2cl-lib:fref x-%data% + (2 2) + ((1 ldx) (1 *)) + x-%offset%) + xi1)) + (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 (f2cl-lib:fref x-%data% + (1 2) + ((1 ldx) (1 *)) + x-%offset%) + xi1) + (setf (f2cl-lib:fref x-%data% + (2 2) + ((1 ldx) (1 *)) + x-%offset%) + xi2))) + (setf xnorm + (max (+ (abs xr1) (abs xi1)) (+ (abs xr2) (abs xi2)))) + (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 (f2cl-lib:fref x-%data% + (1 2) + ((1 ldx) (1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref x-%data% + (1 2) + ((1 ldx) (1 *)) + x-%offset%))) + (setf (f2cl-lib:fref x-%data% + (2 2) + ((1 ldx) (1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref x-%data% + (2 2) + ((1 ldx) (1 *)) + x-%offset%))) + (setf xnorm (* temp xnorm)) + (setf scale (* temp scale)))))))))) + end_label + (return + (values nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + scale + xnorm + 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::dlaln2 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((member t nil) fixnum + fixnum (double-float) + (double-float) (array double-float (*)) + fixnum (double-float) + (double-float) (array double-float (*)) + fixnum (double-float) + (double-float) (array double-float (*)) + fixnum (double-float) + (double-float) fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil fortran-to-lisp::scale + fortran-to-lisp::xnorm fortran-to-lisp::info) + :calls '(fortran-to-lisp::dladiv fortran-to-lisp::dlamch)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlamch LAPACK} +\pagehead{dlamch}{dlamch} +%\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)) + (let ((eps 0.0) + (sfmin 0.0) + (base 0.0) + (t$ 0.0f0) + (rnd 0.0) + (emin 0.0) + (rmin 0.0) + (emax 0.0) + (rmax 0.0) + (prec 0.0) + (first$ nil)) + (declare (type (member t nil) first$) + (type (single-float) t$) + (type (double-float) prec rmax emax rmin emin rnd base sfmin eps)) + (setq first$ t) + (defun dlamch (cmach) + (declare (type (simple-array character (*)) cmach)) + (f2cl-lib:with-multi-array-data + ((cmach character cmach-%data% cmach-%offset%)) + (prog ((rmach 0.0) (small 0.0) (t$ 0.0) (beta 0) (imax 0) (imin 0) + (it 0) (lrnd nil) (dlamch 0.0)) + (declare (type fixnum beta imax imin it) + (type (member t nil) lrnd) + (type (double-float) rmach small t$ dlamch)) + (cond + (first$ + (setf first$ nil) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dlamc2 beta it lrnd eps imin rmin imax rmax) + (declare (ignore)) + (setf beta var-0) + (setf it var-1) + (setf lrnd var-2) + (setf eps var-3) + (setf imin var-4) + (setf rmin var-5) + (setf imax var-6) + (setf rmax var-7)) + (setf base (coerce (the fixnum beta) 'double-float)) + (setf t$ (coerce (the fixnum it) 'double-float)) + (cond + (lrnd + (setf rnd one) + (setf eps (/ (expt base (f2cl-lib:int-sub 1 it)) 2))) + (t + (setf rnd zero) + (setf eps (expt base (f2cl-lib:int-sub 1 it))))) + (setf prec (* eps base)) + (setf emin (coerce (the fixnum imin) 'double-float)) + (setf emax (coerce (the fixnum imax) 'double-float)) + (setf sfmin rmin) + (setf small (/ one rmax)) + (cond + ((>= small sfmin) + (setf sfmin (* small (+ one eps))))))) + (cond + ((lsame cmach "E") + (setf rmach eps)) + ((lsame cmach "S") + (setf rmach sfmin)) + ((lsame cmach "B") + (setf rmach base)) + ((lsame cmach "P") + (setf rmach prec)) + ((lsame cmach "N") + (setf rmach t$)) + ((lsame cmach "R") + (setf rmach rnd)) + ((lsame cmach "M") + (setf rmach emin)) + ((lsame cmach "U") + (setf rmach rmin)) + ((lsame cmach "L") + (setf rmach emax)) + ((lsame cmach "O") + (setf rmach rmax))) + (setf dlamch rmach) + end_label + (return (values dlamch 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::dlamch + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1))) + :return-values '(nil) + :calls '(fortran-to-lisp::dlamc2 fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlamc1 LAPACK} +\pagehead{dlamc1}{dlamc1} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let ((lieee1 nil) (lbeta 0) (lrnd nil) (f2cl-lib:lt 0) (first$ nil)) + (declare (type fixnum f2cl-lib:lt lbeta) + (type (member t nil) first$ lrnd lieee1)) + (setq first$ t) + (defun dlamc1 (beta t$ rnd ieee1) + (declare (type (member t nil) ieee1 rnd) + (type fixnum t$ beta)) + (prog ((a 0.0) (b 0.0) (c 0.0) (f 0.0) (one 0.0) (qtr 0.0) (savec 0.0) + (t1 0.0) (t2 0.0)) + (declare (type (double-float) t2 t1 savec qtr one f c b a)) + (cond + (first$ + (tagbody + (setf first$ nil) + (setf one (coerce (the fixnum 1) 'double-float)) + (setf a (coerce (the fixnum 1) 'double-float)) + (setf c (coerce (the fixnum 1) 'double-float)) + label10 + (cond + ((= c one) + (setf a (* 2 a)) + (setf c + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 a one) + (declare (ignore)) + (setf a var-0) + (setf one var-1) + ret-val)) + (setf c + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 c (- a)) + (declare (ignore var-1)) + (setf c var-0) + ret-val)) + (go label10))) + (setf b (coerce (the fixnum 1) 'double-float)) + (setf c + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 a b) + (declare (ignore)) + (setf a var-0) + (setf b var-1) + ret-val)) + label20 + (cond + ((= c a) + (setf b (* 2 b)) + (setf c + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 a b) + (declare (ignore)) + (setf a var-0) + (setf b var-1) + ret-val)) + (go label20))) + (setf qtr (/ one 4)) + (setf savec c) + (setf c + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 c (- a)) + (declare (ignore var-1)) + (setf c var-0) + ret-val)) + (setf lbeta (f2cl-lib:int (+ c qtr))) + (setf b (coerce (the fixnum lbeta) 'double-float)) + (setf f (dlamc3 (/ b 2) (/ (- b) 100))) + (setf c + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 f a) + (declare (ignore)) + (setf f var-0) + (setf a var-1) + ret-val)) + (cond + ((= c a) + (setf lrnd t)) + (t + (setf lrnd nil))) + (setf f (dlamc3 (/ b 2) (/ b 100))) + (setf c + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 f a) + (declare (ignore)) + (setf f var-0) + (setf a var-1) + ret-val)) + (if (and lrnd (= c a)) (setf lrnd nil)) + (setf t1 + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 (/ b 2) a) + (declare (ignore var-0)) + (setf a var-1) + ret-val)) + (setf t2 + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 (/ b 2) savec) + (declare (ignore var-0)) + (setf savec var-1) + ret-val)) + (setf lieee1 (and (= t1 a) (> t2 savec) lrnd)) + (setf f2cl-lib:lt 0) + (setf a (coerce (the fixnum 1) 'double-float)) + (setf c (coerce (the fixnum 1) 'double-float)) + label30 + (cond + ((= c one) + (setf f2cl-lib:lt (f2cl-lib:int-add f2cl-lib:lt 1)) + (setf a (* a lbeta)) + (setf c + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 a one) + (declare (ignore)) + (setf a var-0) + (setf one var-1) + ret-val)) + (setf c + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 c (- a)) + (declare (ignore var-1)) + (setf c var-0) + ret-val)) + (go label30)))))) + (setf beta lbeta) + (setf t$ f2cl-lib:lt) + (setf rnd lrnd) + (setf ieee1 lieee1) + end_label + (return (values beta t$ rnd ieee1))))) + +(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::dlamc1 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (member t nil) (member t nil)) + :return-values '(fortran-to-lisp::beta fortran-to-lisp::t$ + fortran-to-lisp::rnd fortran-to-lisp::ieee1) + :calls '(fortran-to-lisp::dlamc3)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlamc2 LAPACK} +\pagehead{dlamc2}{dlamc2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let ((lbeta 0) + (lemax 0) + (lemin 0) + (leps 0.0) + (lrmax 0.0) + (lrmin 0.0) + (f2cl-lib:lt 0) + (first$ nil) + (iwarn nil)) + (declare (type (member t nil) iwarn first$) + (type (double-float) lrmin lrmax leps) + (type fixnum f2cl-lib:lt lemin lemax lbeta)) + (setq first$ t) + (setq iwarn nil) + (defun dlamc2 (beta t$ rnd eps emin rmin emax rmax) + (declare (type (double-float) rmax rmin eps) + (type (member t nil) rnd) + (type fixnum emax emin t$ beta)) + (prog ((a 0.0) (b 0.0) (c 0.0) (half 0.0) (one 0.0) (rbase 0.0) + (sixth$ 0.0) (small 0.0) (third$ 0.0) (two 0.0) (zero 0.0) (gnmin 0) + (gpmin 0) (i 0) (ngnmin 0) (ngpmin 0) (ieee nil) (lieee1 nil) + (lrnd nil)) + (declare (type (member t nil) lrnd lieee1 ieee) + (type fixnum ngpmin ngnmin i gpmin gnmin) + (type (double-float) zero two third$ small sixth$ rbase one half + c b a)) + (cond + (first$ + (tagbody + (setf first$ nil) + (setf zero (coerce (the fixnum 0) 'double-float)) + (setf one (coerce (the fixnum 1) 'double-float)) + (setf two (coerce (the fixnum 2) 'double-float)) + (multiple-value-bind (var-0 var-1 var-2 var-3) + (dlamc1 lbeta f2cl-lib:lt lrnd lieee1) + (declare (ignore)) + (setf lbeta var-0) + (setf f2cl-lib:lt var-1) + (setf lrnd var-2) + (setf lieee1 var-3)) + (setf b (coerce (the fixnum lbeta) 'double-float)) + (setf a (expt b (f2cl-lib:int-sub f2cl-lib:lt))) + (setf leps a) + (setf b (/ two 3)) + (setf half (/ one 2)) + (setf sixth$ + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 b (- half)) + (declare (ignore var-1)) + (setf b var-0) + ret-val)) + (setf third$ + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 sixth$ sixth$) + (declare (ignore)) + (setf sixth$ var-0) + (setf sixth$ var-1) + ret-val)) + (setf b + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 third$ (- half)) + (declare (ignore var-1)) + (setf third$ var-0) + ret-val)) + (setf b + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 b sixth$) + (declare (ignore)) + (setf b var-0) + (setf sixth$ var-1) + ret-val)) + (setf b (abs b)) + (if (< b leps) (setf b leps)) + (setf leps (coerce (the fixnum 1) 'double-float)) + label10 + (cond + ((and (> leps b) (> b zero)) + (setf leps b) + (setf c (dlamc3 (* half leps) (* (expt two 5) (expt leps 2)))) + (setf c + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 half (- c)) + (declare (ignore var-1)) + (setf half var-0) + ret-val)) + (setf b + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 half c) + (declare (ignore)) + (setf half var-0) + (setf c var-1) + ret-val)) + (setf c + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 half (- b)) + (declare (ignore var-1)) + (setf half var-0) + ret-val)) + (setf b + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 half c) + (declare (ignore)) + (setf half var-0) + (setf c var-1) + ret-val)) + (go label10))) + (if (< a leps) (setf leps a)) + (setf rbase (/ one lbeta)) + (setf small one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i 3) nil) + (tagbody + (setf small + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 (* small rbase) zero) + (declare (ignore var-0)) + (setf zero var-1) + ret-val)))) + (setf a + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 one small) + (declare (ignore)) + (setf one var-0) + (setf small var-1) + ret-val)) + (multiple-value-bind (var-0 var-1 var-2) + (dlamc4 ngpmin one lbeta) + (declare (ignore var-1 var-2)) + (setf ngpmin var-0)) + (multiple-value-bind (var-0 var-1 var-2) + (dlamc4 ngnmin (- one) lbeta) + (declare (ignore var-1 var-2)) + (setf ngnmin var-0)) + (multiple-value-bind (var-0 var-1 var-2) + (dlamc4 gpmin a lbeta) + (declare (ignore var-1 var-2)) + (setf gpmin var-0)) + (multiple-value-bind (var-0 var-1 var-2) + (dlamc4 gnmin (- a) lbeta) + (declare (ignore var-1 var-2)) + (setf gnmin var-0)) + (setf ieee nil) + (cond + ((and (= ngpmin ngnmin) (= gpmin gnmin)) + (cond + ((= ngpmin gpmin) + (setf lemin ngpmin)) + ((= (f2cl-lib:int-add gpmin (f2cl-lib:int-sub ngpmin)) 3) + (setf lemin + (f2cl-lib:int-add (f2cl-lib:int-sub ngpmin 1) + f2cl-lib:lt)) + (setf ieee t)) + (t + (setf lemin + (min (the fixnum ngpmin) + (the fixnum gpmin))) + (setf iwarn t)))) + ((and (= ngpmin gpmin) (= ngnmin gnmin)) + (cond + ((= (abs (f2cl-lib:int-add ngpmin (f2cl-lib:int-sub ngnmin))) 1) + (setf lemin + (max (the fixnum ngpmin) + (the fixnum ngnmin)))) + (t + (setf lemin + (min (the fixnum ngpmin) + (the fixnum ngnmin))) + (setf iwarn t)))) + ((and + (= (abs (f2cl-lib:int-add ngpmin (f2cl-lib:int-sub ngnmin))) 1) + (= gpmin gnmin)) + (cond + ((= + (f2cl-lib:int-add gpmin + (f2cl-lib:int-sub + (min (the fixnum ngpmin) + (the fixnum ngnmin)))) + 3) + (setf lemin + (f2cl-lib:int-add + (f2cl-lib:int-sub + (max (the fixnum ngpmin) + (the fixnum ngnmin)) + 1) + f2cl-lib:lt))) + (t + (setf lemin + (min (the fixnum ngpmin) + (the fixnum ngnmin))) + (setf iwarn t)))) + (t + (setf lemin + (min (the fixnum ngpmin) + (the fixnum ngnmin) + (the fixnum gpmin) + (the fixnum gnmin))) + (setf iwarn t))) + (cond + (iwarn + (setf first$ t) + (format t "~&~s~a~s~%~s~%~s~s~%" + "WARNING. The value EMIN may be incorrect:- EMIN = " + lemin + " If, after inspection, the value EMIN looks acceptable " + "please comment out " + " the IF block as marked within the code of routine DLAMC2," + " otherwise supply EMIN explicitly."))) + (setf ieee (or ieee lieee1)) + (setf lrmin (coerce (the fixnum 1) 'double-float)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add 1 (f2cl-lib:int-sub lemin))) + nil) + (tagbody + (setf lrmin + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 (* lrmin rbase) zero) + (declare (ignore var-0)) + (setf zero var-1) + ret-val)))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5) + (dlamc5 lbeta f2cl-lib:lt lemin ieee lemax lrmax) + (declare (ignore var-1)) + (setf lbeta var-0) + (setf lemin var-2) + (setf ieee var-3) + (setf lemax var-4) + (setf lrmax var-5))))) + (setf beta lbeta) + (setf t$ f2cl-lib:lt) + (setf rnd lrnd) + (setf eps leps) + (setf emin lemin) + (setf rmin lrmin) + (setf emax lemax) + (setf rmax lrmax) + end_label + (return (values beta t$ rnd eps emin rmin emax rmax))))) + +(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::dlamc2 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (member t nil) (double-float) + fixnum (double-float) + fixnum (double-float)) + :return-values '(fortran-to-lisp::beta fortran-to-lisp::t$ + fortran-to-lisp::rnd fortran-to-lisp::eps + fortran-to-lisp::emin fortran-to-lisp::rmin + fortran-to-lisp::emax fortran-to-lisp::rmax) + :calls '(fortran-to-lisp::dlamc5 fortran-to-lisp::dlamc4 + fortran-to-lisp::dlamc3 fortran-to-lisp::dlamc1)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlamc3 LAPACK} +\pagehead{dlamc3}{dlamc3} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun dlamc3 (a b) + (declare (type (double-float) b a)) + (prog ((dlamc3 0.0)) + (declare (type (double-float) dlamc3)) + (setf dlamc3 (+ a b)) + (return (values dlamc3 a b)))) + +(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::dlamc3 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((double-float) (double-float)) + :return-values '(fortran-to-lisp::a fortran-to-lisp::b) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlamc4 LAPACK} +\pagehead{dlamc4}{dlamc4} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun dlamc4 (emin start base) + (declare (type (double-float) start) (type fixnum base emin)) + (prog ((a 0.0) (b1 0.0) (b2 0.0) (c1 0.0) (c2 0.0) (d1 0.0) (d2 0.0) + (one 0.0) (rbase 0.0) (zero 0.0) (i 0)) + (declare (type fixnum i) + (type (double-float) zero rbase one d2 d1 c2 c1 b2 b1 a)) + (setf a start) + (setf one (coerce (the fixnum 1) 'double-float)) + (setf rbase (/ one base)) + (setf zero (coerce (the fixnum 0) 'double-float)) + (setf emin 1) + (setf b1 + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 (* a rbase) zero) + (declare (ignore var-0)) + (setf zero var-1) + ret-val)) + (setf c1 a) + (setf c2 a) + (setf d1 a) + (setf d2 a) + label10 + (cond + ((and (= c1 a) (= c2 a) (= d1 a) (= d2 a)) + (setf emin (f2cl-lib:int-sub emin 1)) + (setf a b1) + (setf b1 + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 (/ a base) zero) + (declare (ignore var-0)) + (setf zero var-1) + ret-val)) + (setf c1 + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 (* b1 base) zero) + (declare (ignore var-0)) + (setf zero var-1) + ret-val)) + (setf d1 zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i base) nil) + (tagbody (setf d1 (+ d1 b1)) label20)) + (setf b2 + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 (* a rbase) zero) + (declare (ignore var-0)) + (setf zero var-1) + ret-val)) + (setf c2 + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 (/ b2 rbase) zero) + (declare (ignore var-0)) + (setf zero var-1) + ret-val)) + (setf d2 zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i base) nil) + (tagbody (setf d2 (+ d2 b2)) label30)) + (go label10))) + end_label + (return (values emin 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::dlamc4 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum (double-float) + fixnum) + :return-values '(fortran-to-lisp::emin nil nil) + :calls '(fortran-to-lisp::dlamc3)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlamc5 LAPACK} +\pagehead{dlamc5}{dlamc5} +%\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 dlamc5 (beta p emin ieee emax rmax) + (declare (type (double-float) rmax) + (type (member t nil) ieee) + (type fixnum emax emin p beta)) + (prog ((oldy 0.0) (recbas 0.0) (y 0.0) (z 0.0) (exbits 0) (expsum 0) (i 0) + (lexp 0) (nbits 0) (try 0) (uexp 0)) + (declare (type (double-float) oldy recbas y z) + (type fixnum exbits expsum i lexp nbits try uexp)) + (setf lexp 1) + (setf exbits 1) + label10 + (setf try (f2cl-lib:int-mul lexp 2)) + (cond + ((<= try (f2cl-lib:int-sub emin)) + (setf lexp try) + (setf exbits (f2cl-lib:int-add exbits 1)) + (go label10))) + (cond + ((= lexp (f2cl-lib:int-sub emin)) + (setf uexp lexp)) + (t + (setf uexp try) + (setf exbits (f2cl-lib:int-add exbits 1)))) + (cond + ((> (f2cl-lib:int-add uexp emin) + (f2cl-lib:int-add (f2cl-lib:int-sub lexp) (f2cl-lib:int-sub emin))) + (setf expsum (f2cl-lib:int-mul 2 lexp))) + (t + (setf expsum (f2cl-lib:int-mul 2 uexp)))) + (setf emax (f2cl-lib:int-sub (f2cl-lib:int-add expsum emin) 1)) + (setf nbits (f2cl-lib:int-add 1 exbits p)) + (cond + ((and (= (mod nbits 2) 1) (= beta 2)) + (setf emax (f2cl-lib:int-sub emax 1)))) + (cond + (ieee + (setf emax (f2cl-lib:int-sub emax 1)))) + (setf recbas (/ one beta)) + (setf z (- beta one)) + (setf y zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i p) nil) + (tagbody + (setf z (* z recbas)) + (if (< y one) (setf oldy y)) + (setf y + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 y z) + (declare (ignore)) + (setf y var-0) + (setf z var-1) + ret-val)))) + (if (>= y one) (setf y oldy)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i emax) nil) + (tagbody + (setf y + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 (* y beta) zero) + (declare (ignore var-0)) + (setf zero var-1) + ret-val)))) + (setf rmax y) + end_label + (return (values beta nil emin ieee emax rmax))))) + +(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::dlamc5 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + fixnum (member t nil) + fixnum (double-float)) + :return-values '(fortran-to-lisp::beta nil fortran-to-lisp::emin + fortran-to-lisp::ieee fortran-to-lisp::emax + fortran-to-lisp::rmax) + :calls '(fortran-to-lisp::dlamc3)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlamrg LAPACK} +\pagehead{dlamrg}{dlamrg} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun dlamrg (n1 n2 a dtrd1 dtrd2 indx) + (declare (type (array fixnum (*)) indx) + (type (array double-float (*)) a) + (type fixnum dtrd2 dtrd1 n2 n1)) + (f2cl-lib:with-multi-array-data + ((a double-float a-%data% a-%offset%) + (indx fixnum indx-%data% indx-%offset%)) + (prog ((i 0) (ind1 0) (ind2 0) (n1sv 0) (n2sv 0)) + (declare (type fixnum n2sv n1sv ind2 ind1 i)) + (setf n1sv n1) + (setf n2sv n2) + (cond + ((> dtrd1 0) + (setf ind1 1)) + (t + (setf ind1 n1))) + (cond + ((> dtrd2 0) + (setf ind2 (f2cl-lib:int-add 1 n1))) + (t + (setf ind2 (f2cl-lib:int-add n1 n2)))) + (setf i 1) + label10 + (cond + ((and (> n1sv 0) (> n2sv 0)) + (cond + ((<= (f2cl-lib:fref a (ind1) ((1 *))) + (f2cl-lib:fref a (ind2) ((1 *)))) + (setf (f2cl-lib:fref indx-%data% (i) ((1 *)) indx-%offset%) ind1) + (setf i (f2cl-lib:int-add i 1)) + (setf ind1 (f2cl-lib:int-add ind1 dtrd1)) + (setf n1sv (f2cl-lib:int-sub n1sv 1))) + (t + (setf (f2cl-lib:fref indx-%data% (i) ((1 *)) indx-%offset%) ind2) + (setf i (f2cl-lib:int-add i 1)) + (setf ind2 (f2cl-lib:int-add ind2 dtrd2)) + (setf n2sv (f2cl-lib:int-sub n2sv 1)))) + (go label10))) + (cond + ((= n1sv 0) + (f2cl-lib:fdo (n1sv 1 (f2cl-lib:int-add n1sv 1)) + ((> n1sv n2sv) nil) + (tagbody + (setf (f2cl-lib:fref indx-%data% (i) ((1 *)) indx-%offset%) ind2) + (setf i (f2cl-lib:int-add i 1)) + (setf ind2 (f2cl-lib:int-add ind2 dtrd2))))) + (t + (f2cl-lib:fdo (n2sv 1 (f2cl-lib:int-add n2sv 1)) + ((> n2sv n1sv) nil) + (tagbody + (setf (f2cl-lib:fref indx-%data% (i) ((1 *)) indx-%offset%) ind1) + (setf i (f2cl-lib:int-add i 1)) + (setf ind1 (f2cl-lib:int-add ind1 dtrd1)))))) + end_label + (return (values 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::dlamrg + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (array double-float (*)) fixnum + fixnum + (array fixnum (*))) + :return-values '(nil nil nil nil nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlange LAPACK} +\pagehead{dlange}{dlange} +%\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 dlange (norm m n a lda work) + (declare (type (array double-float (*)) work a) + (type fixnum lda n m) + (type (simple-array character (*)) norm)) + (f2cl-lib:with-multi-array-data + ((norm character norm-%data% norm-%offset%) + (a double-float a-%data% a-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((scale 0.0) (sum 0.0) (value 0.0) (i 0) (j 0) (dlange 0.0)) + (declare (type fixnum i j) + (type (double-float) scale sum value dlange)) + (cond + ((= (min (the fixnum m) (the fixnum n)) 0) + (setf value zero)) + ((lsame norm "M") + (setf value zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf value + (max value + (abs + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%))))))))) + ((or (lsame norm "O") (f2cl-lib:fstring-= norm "1")) + (setf value zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf sum zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf sum + (+ sum + (abs + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf value (max value sum))))) + ((lsame norm "I") + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) + zero))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) + (+ + (f2cl-lib:fref work-%data% + (i) + ((1 *)) + work-%offset%) + (abs + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))))) + (setf value zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf value + (max value + (f2cl-lib:fref work-%data% + (i) + ((1 *)) + work-%offset%)))))) + ((or (lsame norm "F") (lsame norm "E")) + (setf scale zero) + (setf sum one) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlassq m + (f2cl-lib:array-slice a double-float (1 j) ((1 lda) (1 *))) + 1 scale sum) + (declare (ignore var-0 var-1 var-2)) + (setf scale var-3) + (setf sum var-4)))) + (setf value (* scale (f2cl-lib:fsqrt sum))))) + (setf dlange value) + end_label + (return (values dlange 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::dlange + 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 (*))) + :return-values '(nil nil nil nil nil nil) + :calls '(fortran-to-lisp::dlassq fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlanhs LAPACK} +\pagehead{dlanhs}{dlanhs} +%\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 dlanhs (norm n a lda work) + (declare (type (array double-float (*)) work a) + (type fixnum lda n) + (type (simple-array character (*)) norm)) + (f2cl-lib:with-multi-array-data + ((norm character norm-%data% norm-%offset%) + (a double-float a-%data% a-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((scale 0.0) (sum 0.0) (value 0.0) (i 0) (j 0) (dlanhs 0.0)) + (declare (type fixnum i j) + (type (double-float) scale sum value dlanhs)) + (cond + ((= n 0) + (setf value zero)) + ((lsame norm "M") + (setf value zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j 1)))) + nil) + (tagbody + (setf value + (max value + (abs + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%))))))))) + ((or (lsame norm "O") (f2cl-lib:fstring-= norm "1")) + (setf value zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf sum zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j 1)))) + nil) + (tagbody + (setf sum + (+ sum + (abs + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf value (max value sum))))) + ((lsame norm "I") + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) + zero))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j 1)))) + nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) + (+ + (f2cl-lib:fref work-%data% + (i) + ((1 *)) + work-%offset%) + (abs + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))))) + (setf value zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf value + (max value + (f2cl-lib:fref work-%data% + (i) + ((1 *)) + work-%offset%)))))) + ((or (lsame norm "F") (lsame norm "E")) + (setf scale zero) + (setf sum one) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlassq + (min (the fixnum n) + (the fixnum (f2cl-lib:int-add j 1))) + (f2cl-lib:array-slice a double-float (1 j) ((1 lda) (1 *))) + 1 scale sum) + (declare (ignore var-0 var-1 var-2)) + (setf scale var-3) + (setf sum var-4)))) + (setf value (* scale (f2cl-lib:fsqrt sum))))) + (setf dlanhs value) + end_label + (return (values dlanhs 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::dlanhs + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum (array double-float (*)) + fixnum (array double-float (*))) + :return-values '(nil nil nil nil nil) + :calls '(fortran-to-lisp::dlassq fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlanst LAPACK} +\pagehead{dlanst}{dlanst} +%\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 dlanst (norm n d e) + (declare (type (array double-float (*)) e d) + (type fixnum n) + (type (simple-array character (*)) norm)) + (f2cl-lib:with-multi-array-data + ((norm character norm-%data% norm-%offset%) + (d double-float d-%data% d-%offset%) + (e double-float e-%data% e-%offset%)) + (prog ((anorm 0.0) (scale 0.0) (sum 0.0) (i 0) (dlanst 0.0)) + (declare (type fixnum i) + (type (double-float) anorm scale sum dlanst)) + (cond + ((<= n 0) + (setf anorm zero)) + ((lsame norm "M") + (setf anorm (abs (f2cl-lib:fref d-%data% (n) ((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 anorm + (max anorm + (abs + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)))) + (setf anorm + (max anorm + (abs + (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%))))))) + ((or (lsame norm "O") (f2cl-lib:fstring-= norm "1") (lsame norm "I")) + (cond + ((= n 1) + (setf anorm + (abs (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%)))) + (t + (setf anorm + (max + (+ (abs (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%)) + (abs + (f2cl-lib:fref e-%data% (1) ((1 *)) e-%offset%))) + (+ + (abs + (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub n 1)) + ((1 *)) + e-%offset%)) + (abs (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%))))) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add n (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf anorm + (max anorm + (+ + (abs + (f2cl-lib:fref d-%data% + (i) + ((1 *)) + d-%offset%)) + (abs + (f2cl-lib:fref e-%data% + (i) + ((1 *)) + e-%offset%)) + (abs + (f2cl-lib:fref e-%data% + ((f2cl-lib:int-sub i 1)) + ((1 *)) + e-%offset%)))))))))) + ((or (lsame norm "F") (lsame norm "E")) + (setf scale zero) + (setf sum one) + (cond + ((> n 1) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlassq (f2cl-lib:int-sub n 1) e 1 scale sum) + (declare (ignore var-0 var-1 var-2)) + (setf scale var-3) + (setf sum var-4)) + (setf sum (* 2 sum)))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlassq n d 1 scale sum) + (declare (ignore var-0 var-1 var-2)) + (setf scale var-3) + (setf sum var-4)) + (setf anorm (* scale (f2cl-lib:fsqrt sum))))) + (setf dlanst anorm) + end_label + (return (values dlanst 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::dlanst + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum (array double-float (*)) + (array double-float (*))) + :return-values '(nil nil nil nil) + :calls '(fortran-to-lisp::dlassq fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlanv2 LAPACK} +\pagehead{dlanv2}{dlanv2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0) (half 0.5) (one 1.0) (multpl 4.0)) + (declare (type (double-float 0.0 0.0) zero) + (type (double-float 0.5 0.5) half) + (type (double-float 1.0 1.0) one) + (type (double-float 4.0 4.0) multpl)) + (defun dlanv2 (a b c d rt1r rt1i rt2r rt2i cs sn) + (declare (type (double-float) sn cs rt2i rt2r rt1i rt1r d c b a)) + (prog ((aa 0.0) (bb 0.0) (bcmax 0.0) (bcmis 0.0) (cc 0.0) (cs1 0.0) + (dd 0.0) (eps 0.0) (p 0.0) (sab 0.0) (sac 0.0) (scale 0.0) + (sigma 0.0) (sn1 0.0) (tau 0.0) (temp 0.0) (z 0.0)) + (declare (type (double-float) aa bb bcmax bcmis cc cs1 dd eps p sab sac + scale sigma sn1 tau temp z)) + (setf eps (dlamch "P")) + (cond + ((= c zero) + (setf cs one) + (setf sn zero) + (go label10)) + ((= b zero) + (setf cs zero) + (setf sn one) + (setf temp d) + (setf d a) + (setf a temp) + (setf b (- c)) + (setf c zero) + (go label10)) + ((and (= (+ a (- d)) zero) + (/= (f2cl-lib:sign one b) (f2cl-lib:sign one c))) + (setf cs one) + (setf sn zero) + (go label10)) + (t + (setf temp (- a d)) + (setf p (* half temp)) + (setf bcmax (max (abs b) (abs c))) + (setf bcmis + (* (min (abs b) (abs c)) + (f2cl-lib:sign one b) + (f2cl-lib:sign one c))) + (setf scale (max (abs p) bcmax)) + (setf z (+ (* (/ p scale) p) (* (/ bcmax scale) bcmis))) + (cond + ((>= z (* multpl eps)) + (setf z + (+ p + (f2cl-lib:sign + (* (f2cl-lib:fsqrt scale) (f2cl-lib:fsqrt z)) + p))) + (setf a (+ d z)) + (setf d (- d (* (/ bcmax z) bcmis))) + (setf tau (dlapy2 c z)) + (setf cs (/ z tau)) + (setf sn (/ c tau)) + (setf b (- b c)) + (setf c zero)) + (t + (setf sigma (+ b c)) + (setf tau (dlapy2 sigma temp)) + (setf cs (f2cl-lib:fsqrt (* half (+ one (/ (abs sigma) tau))))) + (setf sn (* (- (/ p (* tau cs))) (f2cl-lib:sign one sigma))) + (setf aa (+ (* a cs) (* b sn))) + (setf bb (+ (* (- a) sn) (* b cs))) + (setf cc (+ (* c cs) (* d sn))) + (setf dd (+ (* (- c) sn) (* d cs))) + (setf a (+ (* aa cs) (* cc sn))) + (setf b (+ (* bb cs) (* dd sn))) + (setf c (+ (* (- aa) sn) (* cc cs))) + (setf d (+ (* (- bb) sn) (* dd cs))) + (setf temp (* half (+ a d))) + (setf a temp) + (setf d temp) + (cond + ((/= c zero) + (cond + ((/= b zero) + (cond + ((= (f2cl-lib:sign one b) (f2cl-lib:sign one c)) + (setf sab (f2cl-lib:fsqrt (abs b))) + (setf sac (f2cl-lib:fsqrt (abs c))) + (setf p (f2cl-lib:sign (* sab sac) c)) + (setf tau (/ one (f2cl-lib:fsqrt (abs (+ b c))))) + (setf a (+ temp p)) + (setf d (- temp p)) + (setf b (- b c)) + (setf c zero) + (setf cs1 (* sab tau)) + (setf sn1 (* sac tau)) + (setf temp (- (* cs cs1) (* sn sn1))) + (setf sn (+ (* cs sn1) (* sn cs1))) + (setf cs temp)))) + (t + (setf b (- c)) + (setf c zero) + (setf temp cs) + (setf cs (- sn)) + (setf sn temp))))))))) + label10 + (setf rt1r a) + (setf rt2r d) + (cond + ((= c zero) + (setf rt1i zero) + (setf rt2i zero)) + (t + (setf rt1i (* (f2cl-lib:fsqrt (abs b)) (f2cl-lib:fsqrt (abs c)))) + (setf rt2i (- rt1i)))) + end_label + (return (values a b c d rt1r rt1i rt2r rt2i cs sn))))) + +(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::dlanv2 + 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) + (double-float) (double-float) (double-float) + (double-float)) + :return-values '(fortran-to-lisp::a fortran-to-lisp::b + fortran-to-lisp::c fortran-to-lisp::d + fortran-to-lisp::rt1r fortran-to-lisp::rt1i + fortran-to-lisp::rt2r fortran-to-lisp::rt2i + fortran-to-lisp::cs fortran-to-lisp::sn) + :calls '(fortran-to-lisp::dlapy2 fortran-to-lisp::dlamch)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlapy2 LAPACK} +\pagehead{dlapy2}{dlapy2} +%\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 dlapy2 (x y) + (declare (type (double-float) y x)) + (prog ((w 0.0) (xabs 0.0) (yabs 0.0) (z 0.0) (dlapy2 0.0)) + (declare (type (double-float) w xabs yabs z dlapy2)) + (setf xabs (abs x)) + (setf yabs (abs y)) + (setf w (max xabs yabs)) + (setf z (min xabs yabs)) + (cond + ((= z zero) + (setf dlapy2 w)) + (t + (setf dlapy2 (* w (f2cl-lib:fsqrt (+ one (expt (/ z w) 2))))))) + (return (values dlapy2 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::dlapy2 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((double-float) (double-float)) + :return-values '(nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlaqtr LAPACK} +\pagehead{dlaqtr}{dlaqtr} +%\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 dlaqtr (ltran lreal n t$ ldt b w scale x work info) + (declare (type (double-float) scale w) + (type (array double-float (*)) work x b t$) + (type fixnum info ldt n) + (type (member t nil) lreal ltran)) + (f2cl-lib:with-multi-array-data + ((t$ double-float t$-%data% t$-%offset%) + (b double-float b-%data% b-%offset%) + (x double-float x-%data% x-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((d (make-array 4 :element-type 'double-float)) + (v (make-array 4 :element-type 'double-float)) (bignum 0.0) + (eps 0.0) (rec 0.0) (scaloc 0.0) (si 0.0) (smin 0.0) (sminw 0.0) + (smlnum 0.0) (sr 0.0) (tjj 0.0) (tmp 0.0) (xj 0.0) (xmax 0.0) + (xnorm 0.0) (z 0.0) (i 0) (ierr 0) (j 0) (j1 0) (j2 0) (jnext 0) + (k 0) (n1 0) (n2 0) (notran nil)) + (declare (type (array double-float (4)) d v) + (type (double-float) bignum eps rec scaloc si smin sminw + smlnum sr tjj tmp xj xmax xnorm z) + (type fixnum i ierr j j1 j2 jnext k n1 n2) + (type (member t nil) notran)) + (setf notran (not ltran)) + (setf info 0) + (if (= n 0) (go end_label)) + (setf eps (dlamch "P")) + (setf smlnum (/ (dlamch "S") eps)) + (setf bignum (/ one smlnum)) + (setf xnorm (dlange "M" n n t$ ldt d)) + (if (not lreal) + (setf xnorm (max xnorm (abs w) (dlange "M" n 1 b n d)))) + (setf smin (max smlnum (* eps xnorm))) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) zero) + (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (j) ((1 *)) work-%offset%) + (dasum (f2cl-lib:int-sub j 1) + (f2cl-lib:array-slice t$ + double-float + (1 j) + ((1 ldt) (1 *))) + 1)))) + (cond + ((not lreal) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) + (+ (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) + (abs + (f2cl-lib:fref b-%data% (i) ((1 *)) b-%offset%))))))));tpd + (setf n2 (f2cl-lib:int-mul 2 n)) + (setf n1 n) + (if (not lreal) (setf n1 n2)) + (setf k (idamax n1 x 1)) + (setf xmax (abs (f2cl-lib:fref x-%data% (k) ((1 *)) x-%offset%))) + (setf scale one) + (cond + ((> xmax bignum) + (setf scale (/ bignum xmax)) + (dscal n1 scale x 1) + (setf xmax bignum))) + (cond + (lreal + (cond + (notran + (setf jnext n) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (if (> j jnext) (go label30)) + (setf j1 j) + (setf j2 j) + (setf jnext (f2cl-lib:int-sub j 1)) + (cond + ((> j 1) + (cond + ((/= + (f2cl-lib:fref t$ + (j + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + ((1 ldt) (1 *))) + zero) + (setf j1 (f2cl-lib:int-sub j 1)) + (setf jnext (f2cl-lib:int-sub j 2)))))) + (cond + ((= j1 j2) + (setf xj + (abs + (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%))) + (setf tjj + (abs + (f2cl-lib:fref t$-%data% + (j1 j1) + ((1 ldt) (1 *)) + t$-%offset%))) + (setf tmp + (f2cl-lib:fref t$-%data% + (j1 j1) + ((1 ldt) (1 *)) + t$-%offset%)) + (cond + ((< tjj smin) + (setf tmp smin) + (setf tjj smin) + (setf info 1))) + (if (= xj zero) (go label30)) + (cond + ((< tjj one) + (cond + ((> xj (* bignum tjj)) + (setf rec (/ one xj)) + (dscal n rec x 1) + (setf scale (* scale rec)) + (setf xmax (* xmax rec)))))) + (setf (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%) + (/ + (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%) + tmp)) + (setf xj + (abs + (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%))) + (cond + ((> xj one) + (setf rec (/ one xj)) + (cond + ((> (f2cl-lib:fref work (j1) ((1 *))) + (* (+ bignum (- xmax)) rec)) + (dscal n rec x 1) + (setf scale (* scale rec)))))) + (cond + ((> j1 1) + (daxpy (f2cl-lib:int-sub j1 1) + (- (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%)) + (f2cl-lib:array-slice t$ + double-float + (1 j1) + ((1 ldt) (1 *))) + 1 x 1) + (setf k (idamax (f2cl-lib:int-sub j1 1) x 1)) + (setf xmax + (abs + (f2cl-lib:fref x-%data% + (k) + ((1 *)) + x-%offset%)))))) + (t + (setf (f2cl-lib:fref d (1 1) ((1 2) (1 2))) + (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%)) + (setf (f2cl-lib:fref d (2 1) ((1 2) (1 2))) + (f2cl-lib:fref x-%data% (j2) ((1 *)) x-%offset%)) + (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) + (dlaln2 nil 2 1 smin one + (f2cl-lib:array-slice t$ + double-float + (j1 j1) + ((1 ldt) (1 *))) + ldt one one d 2 zero zero v 2 scaloc 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-11 + var-12 var-13 var-14)) + (setf scaloc var-15) + (setf xnorm var-16) + (setf ierr var-17)) + (if (/= ierr 0) (setf info 2)) + (cond + ((/= scaloc one) + (dscal n scaloc x 1) + (setf scale (* scale scaloc)))) + (setf (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%) + (f2cl-lib:fref v (1 1) ((1 2) (1 2)))) + (setf (f2cl-lib:fref x-%data% (j2) ((1 *)) x-%offset%) + (f2cl-lib:fref v (2 1) ((1 2) (1 2)))) + (setf xj + (max (abs (f2cl-lib:fref v (1 1) ((1 2) (1 2)))) + (abs (f2cl-lib:fref v (2 1) ((1 2) (1 2)))))) + (cond + ((> xj one) + (setf rec (/ one xj)) + (cond + ((> + (max (f2cl-lib:fref work (j1) ((1 *))) + (f2cl-lib:fref work (j2) ((1 *)))) + (* (+ bignum (- xmax)) rec)) + (dscal n rec x 1) + (setf scale (* scale rec)))))) + (cond + ((> j1 1) + (daxpy (f2cl-lib:int-sub j1 1) + (- (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%)) + (f2cl-lib:array-slice t$ + double-float + (1 j1) + ((1 ldt) (1 *))) + 1 x 1) + (daxpy (f2cl-lib:int-sub j1 1) + (- (f2cl-lib:fref x-%data% (j2) ((1 *)) x-%offset%)) + (f2cl-lib:array-slice t$ + double-float + (1 j2) + ((1 ldt) (1 *))) + 1 x 1) + (setf k (idamax (f2cl-lib:int-sub j1 1) x 1)) + (setf xmax + (abs + (f2cl-lib:fref x-%data% + (k) + ((1 *)) + x-%offset%))))))) + label30))) + (t + (setf jnext 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (if (< j jnext) (go label40)) + (setf j1 j) + (setf j2 j) + (setf jnext (f2cl-lib:int-add j 1)) + (cond + ((< j n) + (cond + ((/= + (f2cl-lib:fref t$ + ((f2cl-lib:int-add j 1) j) + ((1 ldt) (1 *))) + zero) + (setf j2 (f2cl-lib:int-add j 1)) + (setf jnext (f2cl-lib:int-add j 2)))))) + (cond + ((= j1 j2) + (setf xj + (abs + (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%))) + (cond + ((> xmax one) + (setf rec (/ one xmax)) + (cond + ((> (f2cl-lib:fref work (j1) ((1 *))) + (* (+ bignum (- xj)) rec)) + (dscal n rec x 1) + (setf scale (* scale rec)) + (setf xmax (* xmax rec)))))) + (setf (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%) + (- + (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%) + (ddot (f2cl-lib:int-sub j1 1) + (f2cl-lib:array-slice t$ + double-float + (1 j1) + ((1 ldt) (1 *))) + 1 x 1))) + (setf xj + (abs + (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%))) + (setf tjj + (abs + (f2cl-lib:fref t$-%data% + (j1 j1) + ((1 ldt) (1 *)) + t$-%offset%))) + (setf tmp + (f2cl-lib:fref t$-%data% + (j1 j1) + ((1 ldt) (1 *)) + t$-%offset%)) + (cond + ((< tjj smin) + (setf tmp smin) + (setf tjj smin) + (setf info 1))) + (cond + ((< tjj one) + (cond + ((> xj (* bignum tjj)) + (setf rec (/ one xj)) + (dscal n rec x 1) + (setf scale (* scale rec)) + (setf xmax (* xmax rec)))))) + (setf (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%) + (/ + (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%) + tmp)) + (setf xmax + (max xmax + (abs + (f2cl-lib:fref x-%data% + (j1) + ((1 *)) + x-%offset%))))) + (t + (setf xj + (max + (abs + (f2cl-lib:fref x-%data% + (j1) + ((1 *)) + x-%offset%)) + (abs + (f2cl-lib:fref x-%data% + (j2) + ((1 *)) + x-%offset%)))) + (cond + ((> xmax one) + (setf rec (/ one xmax)) + (cond + ((> + (max (f2cl-lib:fref work (j2) ((1 *))) + (f2cl-lib:fref work (j1) ((1 *)))) + (* (+ bignum (- xj)) rec)) + (dscal n rec x 1) + (setf scale (* scale rec)) + (setf xmax (* xmax rec)))))) + (setf (f2cl-lib:fref d (1 1) ((1 2) (1 2))) + (- + (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%) + (ddot (f2cl-lib:int-sub j1 1) + (f2cl-lib:array-slice t$ + double-float + (1 j1) + ((1 ldt) (1 *))) + 1 x 1))) + (setf (f2cl-lib:fref d (2 1) ((1 2) (1 2))) + (- + (f2cl-lib:fref x-%data% (j2) ((1 *)) x-%offset%) + (ddot (f2cl-lib:int-sub j1 1) + (f2cl-lib:array-slice t$ + double-float + (1 j2) + ((1 ldt) (1 *))) + 1 x 1))) + (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) + (dlaln2 t 2 1 smin one + (f2cl-lib:array-slice t$ + double-float + (j1 j1) + ((1 ldt) (1 *))) + ldt one one d 2 zero zero v 2 scaloc 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-11 + var-12 var-13 var-14)) + (setf scaloc var-15) + (setf xnorm var-16) + (setf ierr var-17)) + (if (/= ierr 0) (setf info 2)) + (cond + ((/= scaloc one) + (dscal n scaloc x 1) + (setf scale (* scale scaloc)))) + (setf (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%) + (f2cl-lib:fref v (1 1) ((1 2) (1 2)))) + (setf (f2cl-lib:fref x-%data% (j2) ((1 *)) x-%offset%) + (f2cl-lib:fref v (2 1) ((1 2) (1 2)))) + (setf xmax + (max + (abs + (f2cl-lib:fref x-%data% + (j1) + ((1 *)) + x-%offset%)) + (abs + (f2cl-lib:fref x-%data% + (j2) + ((1 *)) + x-%offset%)) + xmax)))) + label40))))) + (t + (setf sminw (max (* eps (abs w)) smin)) + (cond + (notran + (setf jnext n) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (if (> j jnext) (go label70)) + (setf j1 j) + (setf j2 j) + (setf jnext (f2cl-lib:int-sub j 1)) + (cond + ((> j 1) + (cond + ((/= + (f2cl-lib:fref t$ + (j + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + ((1 ldt) (1 *))) + zero) + (setf j1 (f2cl-lib:int-sub j 1)) + (setf jnext (f2cl-lib:int-sub j 2)))))) + (cond + ((= j1 j2) + (setf z w) + (if (= j1 1) + (setf z + (f2cl-lib:fref b-%data% + (1) + ((1 *)) + b-%offset%))) + (setf xj + (+ + (abs + (f2cl-lib:fref x-%data% + (j1) + ((1 *)) + x-%offset%)) + (abs + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j1)) + ((1 *)) + x-%offset%)))) + (setf tjj + (+ + (abs + (f2cl-lib:fref t$-%data% + (j1 j1) + ((1 ldt) (1 *)) + t$-%offset%)) + (abs z))) + (setf tmp + (f2cl-lib:fref t$-%data% + (j1 j1) + ((1 ldt) (1 *)) + t$-%offset%)) + (cond + ((< tjj sminw) + (setf tmp sminw) + (setf tjj sminw) + (setf info 1))) + (if (= xj zero) (go label70)) + (cond + ((< tjj one) + (cond + ((> xj (* bignum tjj)) + (setf rec (/ one xj)) + (dscal n2 rec x 1) + (setf scale (* scale rec)) + (setf xmax (* xmax rec)))))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5) + (dladiv + (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%) + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j1)) + ((1 *)) + x-%offset%) + tmp z sr si) + (declare (ignore var-0 var-1 var-2 var-3)) + (setf sr var-4) + (setf si var-5)) + (setf (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%) sr) + (setf (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j1)) + ((1 *)) + x-%offset%) + si) + (setf xj + (+ + (abs + (f2cl-lib:fref x-%data% + (j1) + ((1 *)) + x-%offset%)) + (abs + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j1)) + ((1 *)) + x-%offset%)))) + (cond + ((> xj one) + (setf rec (/ one xj)) + (cond + ((> (f2cl-lib:fref work (j1) ((1 *))) + (* (+ bignum (- xmax)) rec)) + (dscal n2 rec x 1) + (setf scale (* scale rec)))))) + (cond + ((> j1 1) + (daxpy (f2cl-lib:int-sub j1 1) + (- (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%)) + (f2cl-lib:array-slice t$ + double-float + (1 j1) + ((1 ldt) (1 *))) + 1 x 1) + (daxpy (f2cl-lib:int-sub j1 1) + (- + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j1)) + ((1 *)) + x-%offset%)) + (f2cl-lib:array-slice t$ + double-float + (1 j1) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice x + double-float + ((+ n 1)) + ((1 *))) + 1) + (setf (f2cl-lib:fref x-%data% (1) ((1 *)) x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (1) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref b-%data% + (j1) + ((1 *)) + b-%offset%) + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j1)) + ((1 *)) + x-%offset%)))) + (setf (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n 1)) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n 1)) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref b-%data% + (j1) + ((1 *)) + b-%offset%) + (f2cl-lib:fref x-%data% + (j1) + ((1 *)) + x-%offset%)))) + (setf xmax zero) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add j1 + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf xmax + (max xmax + (+ + (abs + (f2cl-lib:fref x-%data% + (k) + ((1 *)) + x-%offset%)) + (abs + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add k + n)) + ((1 *)) + x-%offset%)))))))))) + (t + (setf (f2cl-lib:fref d (1 1) ((1 2) (1 2))) + (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%)) + (setf (f2cl-lib:fref d (2 1) ((1 2) (1 2))) + (f2cl-lib:fref x-%data% (j2) ((1 *)) x-%offset%)) + (setf (f2cl-lib:fref d (1 2) ((1 2) (1 2))) + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j1)) + ((1 *)) + x-%offset%)) + (setf (f2cl-lib:fref d (2 2) ((1 2) (1 2))) + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j2)) + ((1 *)) + x-%offset%)) + (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) + (dlaln2 nil 2 2 sminw one + (f2cl-lib:array-slice t$ + double-float + (j1 j1) + ((1 ldt) (1 *))) + ldt one one d 2 zero (- w) v 2 scaloc 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-11 + var-12 var-13 var-14)) + (setf scaloc var-15) + (setf xnorm var-16) + (setf ierr var-17)) + (if (/= ierr 0) (setf info 2)) + (cond + ((/= scaloc one) + (dscal (f2cl-lib:int-mul 2 n) scaloc x 1) + (setf scale (* scaloc scale)))) + (setf (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%) + (f2cl-lib:fref v (1 1) ((1 2) (1 2)))) + (setf (f2cl-lib:fref x-%data% (j2) ((1 *)) x-%offset%) + (f2cl-lib:fref v (2 1) ((1 2) (1 2)))) + (setf (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j1)) + ((1 *)) + x-%offset%) + (f2cl-lib:fref v (1 2) ((1 2) (1 2)))) + (setf (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j2)) + ((1 *)) + x-%offset%) + (f2cl-lib:fref v (2 2) ((1 2) (1 2)))) + (setf xj + (max + (+ (abs (f2cl-lib:fref v (1 1) ((1 2) (1 2)))) + (abs (f2cl-lib:fref v (1 2) ((1 2) (1 2))))) + (+ (abs (f2cl-lib:fref v (2 1) ((1 2) (1 2)))) + (abs (f2cl-lib:fref v (2 2) ((1 2) (1 2))))))) + (cond + ((> xj one) + (setf rec (/ one xj)) + (cond + ((> + (max (f2cl-lib:fref work (j1) ((1 *))) + (f2cl-lib:fref work (j2) ((1 *)))) + (* (+ bignum (- xmax)) rec)) + (dscal n2 rec x 1) + (setf scale (* scale rec)))))) + (cond + ((> j1 1) + (daxpy (f2cl-lib:int-sub j1 1) + (- (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%)) + (f2cl-lib:array-slice t$ + double-float + (1 j1) + ((1 ldt) (1 *))) + 1 x 1) + (daxpy (f2cl-lib:int-sub j1 1) + (- (f2cl-lib:fref x-%data% (j2) ((1 *)) x-%offset%)) + (f2cl-lib:array-slice t$ + double-float + (1 j2) + ((1 ldt) (1 *))) + 1 x 1) + (daxpy (f2cl-lib:int-sub j1 1) + (- + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j1)) + ((1 *)) + x-%offset%)) + (f2cl-lib:array-slice t$ + double-float + (1 j1) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice x + double-float + ((+ n 1)) + ((1 *))) + 1) + (daxpy (f2cl-lib:int-sub j1 1) + (- + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j2)) + ((1 *)) + x-%offset%)) + (f2cl-lib:array-slice t$ + double-float + (1 j2) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice x + double-float + ((+ n 1)) + ((1 *))) + 1) + (setf (f2cl-lib:fref x-%data% (1) ((1 *)) x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (1) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref b-%data% + (j1) + ((1 *)) + b-%offset%) + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j1)) + ((1 *)) + x-%offset%)) + (* + (f2cl-lib:fref b-%data% + (j2) + ((1 *)) + b-%offset%) + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j2)) + ((1 *)) + x-%offset%)))) + (setf (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n 1)) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n 1)) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref b-%data% + (j1) + ((1 *)) + b-%offset%) + (f2cl-lib:fref x-%data% + (j1) + ((1 *)) + x-%offset%)) + (* + (f2cl-lib:fref b-%data% + (j2) + ((1 *)) + b-%offset%) + (f2cl-lib:fref x-%data% + (j2) + ((1 *)) + x-%offset%)))) + (setf xmax zero) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add j1 + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf xmax + (max + (+ + (abs + (f2cl-lib:fref x-%data% + (k) + ((1 *)) + x-%offset%)) + (abs + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add k n)) + ((1 *)) + x-%offset%))) + xmax)))))))) + label70))) + (t + (setf jnext 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (if (< j jnext) (go label80)) + (setf j1 j) + (setf j2 j) + (setf jnext (f2cl-lib:int-add j 1)) + (cond + ((< j n) + (cond + ((/= + (f2cl-lib:fref t$ + ((f2cl-lib:int-add j 1) j) + ((1 ldt) (1 *))) + zero) + (setf j2 (f2cl-lib:int-add j 1)) + (setf jnext (f2cl-lib:int-add j 2)))))) + (cond + ((= j1 j2) + (setf xj + (+ + (abs + (f2cl-lib:fref x-%data% + (j1) + ((1 *)) + x-%offset%)) + (abs + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add j1 n)) + ((1 *)) + x-%offset%)))) + (cond + ((> xmax one) + (setf rec (/ one xmax)) + (cond + ((> (f2cl-lib:fref work (j1) ((1 *))) + (* (+ bignum (- xj)) rec)) + (dscal n2 rec x 1) + (setf scale (* scale rec)) + (setf xmax (* xmax rec)))))) + (setf (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%) + (- + (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%) + (ddot (f2cl-lib:int-sub j1 1) + (f2cl-lib:array-slice t$ + double-float + (1 j1) + ((1 ldt) (1 *))) + 1 x 1))) + (setf (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j1)) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j1)) + ((1 *)) + x-%offset%) + (ddot (f2cl-lib:int-sub j1 1) + (f2cl-lib:array-slice t$ + double-float + (1 j1) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice x + double-float + ((+ n 1)) + ((1 *))) + 1))) + (cond + ((> j1 1) + (setf (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%) + (- + (f2cl-lib:fref x-%data% + (j1) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref b-%data% + (j1) + ((1 *)) + b-%offset%) + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n 1)) + ((1 *)) + x-%offset%)))) + (setf (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j1)) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j1)) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref b-%data% + (j1) + ((1 *)) + b-%offset%) + (f2cl-lib:fref x-%data% + (1) + ((1 *)) + x-%offset%)))))) + (setf xj + (+ + (abs + (f2cl-lib:fref x-%data% + (j1) + ((1 *)) + x-%offset%)) + (abs + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add j1 n)) + ((1 *)) + x-%offset%)))) + (setf z w) + (if (= j1 1) + (setf z + (f2cl-lib:fref b-%data% + (1) + ((1 *)) + b-%offset%))) + (setf tjj + (+ + (abs + (f2cl-lib:fref t$-%data% + (j1 j1) + ((1 ldt) (1 *)) + t$-%offset%)) + (abs z))) + (setf tmp + (f2cl-lib:fref t$-%data% + (j1 j1) + ((1 ldt) (1 *)) + t$-%offset%)) + (cond + ((< tjj sminw) + (setf tmp sminw) + (setf tjj sminw) + (setf info 1))) + (cond + ((< tjj one) + (cond + ((> xj (* bignum tjj)) + (setf rec (/ one xj)) + (dscal n2 rec x 1) + (setf scale (* scale rec)) + (setf xmax (* xmax rec)))))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5) + (dladiv + (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%) + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j1)) + ((1 *)) + x-%offset%) + tmp (- z) sr si) + (declare (ignore var-0 var-1 var-2 var-3)) + (setf sr var-4) + (setf si var-5)) + (setf (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%) sr) + (setf (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add j1 n)) + ((1 *)) + x-%offset%) + si) + (setf xmax + (max + (+ + (abs + (f2cl-lib:fref x-%data% + (j1) + ((1 *)) + x-%offset%)) + (abs + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add j1 n)) + ((1 *)) + x-%offset%))) + xmax))) + (t + (setf xj + (max + (+ + (abs + (f2cl-lib:fref x-%data% + (j1) + ((1 *)) + x-%offset%)) + (abs + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j1)) + ((1 *)) + x-%offset%))) + (+ + (abs + (f2cl-lib:fref x-%data% + (j2) + ((1 *)) + x-%offset%)) + (abs + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j2)) + ((1 *)) + x-%offset%))))) + (cond + ((> xmax one) + (setf rec (/ one xmax)) + (cond + ((> + (max (f2cl-lib:fref work (j1) ((1 *))) + (f2cl-lib:fref work (j2) ((1 *)))) + (f2cl-lib:f2cl/ (+ bignum (- xj)) xmax)) + (dscal n2 rec x 1) + (setf scale (* scale rec)) + (setf xmax (* xmax rec)))))) + (setf (f2cl-lib:fref d (1 1) ((1 2) (1 2))) + (- + (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%) + (ddot (f2cl-lib:int-sub j1 1) + (f2cl-lib:array-slice t$ + double-float + (1 j1) + ((1 ldt) (1 *))) + 1 x 1))) + (setf (f2cl-lib:fref d (2 1) ((1 2) (1 2))) + (- + (f2cl-lib:fref x-%data% (j2) ((1 *)) x-%offset%) + (ddot (f2cl-lib:int-sub j1 1) + (f2cl-lib:array-slice t$ + double-float + (1 j2) + ((1 ldt) (1 *))) + 1 x 1))) + (setf (f2cl-lib:fref d (1 2) ((1 2) (1 2))) + (- + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j1)) + ((1 *)) + x-%offset%) + (ddot (f2cl-lib:int-sub j1 1) + (f2cl-lib:array-slice t$ + double-float + (1 j1) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice x + double-float + ((+ n 1)) + ((1 *))) + 1))) + (setf (f2cl-lib:fref d (2 2) ((1 2) (1 2))) + (- + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j2)) + ((1 *)) + x-%offset%) + (ddot (f2cl-lib:int-sub j1 1) + (f2cl-lib:array-slice t$ + double-float + (1 j2) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice x + double-float + ((+ n 1)) + ((1 *))) + 1))) + (setf (f2cl-lib:fref d (1 1) ((1 2) (1 2))) + (- (f2cl-lib:fref d (1 1) ((1 2) (1 2))) + (* + (f2cl-lib:fref b-%data% + (j1) + ((1 *)) + b-%offset%) + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n 1)) + ((1 *)) + x-%offset%)))) + (setf (f2cl-lib:fref d (2 1) ((1 2) (1 2))) + (- (f2cl-lib:fref d (2 1) ((1 2) (1 2))) + (* + (f2cl-lib:fref b-%data% + (j2) + ((1 *)) + b-%offset%) + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n 1)) + ((1 *)) + x-%offset%)))) + (setf (f2cl-lib:fref d (1 2) ((1 2) (1 2))) + (+ (f2cl-lib:fref d (1 2) ((1 2) (1 2))) + (* + (f2cl-lib:fref b-%data% + (j1) + ((1 *)) + b-%offset%) + (f2cl-lib:fref x-%data% + (1) + ((1 *)) + x-%offset%)))) + (setf (f2cl-lib:fref d (2 2) ((1 2) (1 2))) + (+ (f2cl-lib:fref d (2 2) ((1 2) (1 2))) + (* + (f2cl-lib:fref b-%data% + (j2) + ((1 *)) + b-%offset%) + (f2cl-lib:fref x-%data% + (1) + ((1 *)) + x-%offset%)))) + (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) + (dlaln2 t 2 2 sminw one + (f2cl-lib:array-slice t$ + double-float + (j1 j1) + ((1 ldt) (1 *))) + ldt one one d 2 zero w v 2 scaloc 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-11 + var-12 var-13 var-14)) + (setf scaloc var-15) + (setf xnorm var-16) + (setf ierr var-17)) + (if (/= ierr 0) (setf info 2)) + (cond + ((/= scaloc one) + (dscal n2 scaloc x 1) + (setf scale (* scaloc scale)))) + (setf (f2cl-lib:fref x-%data% (j1) ((1 *)) x-%offset%) + (f2cl-lib:fref v (1 1) ((1 2) (1 2)))) + (setf (f2cl-lib:fref x-%data% (j2) ((1 *)) x-%offset%) + (f2cl-lib:fref v (2 1) ((1 2) (1 2)))) + (setf (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j1)) + ((1 *)) + x-%offset%) + (f2cl-lib:fref v (1 2) ((1 2) (1 2)))) + (setf (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j2)) + ((1 *)) + x-%offset%) + (f2cl-lib:fref v (2 2) ((1 2) (1 2)))) + (setf xmax + (max + (+ + (abs + (f2cl-lib:fref x-%data% + (j1) + ((1 *)) + x-%offset%)) + (abs + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j1)) + ((1 *)) + x-%offset%))) + (+ + (abs + (f2cl-lib:fref x-%data% + (j2) + ((1 *)) + x-%offset%)) + (abs + (f2cl-lib:fref x-%data% + ((f2cl-lib:int-add n j2)) + ((1 *)) + x-%offset%))) + xmax)))) + label80)))))) + end_label + (return (values nil nil nil nil nil nil nil scale 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::dlaqtr + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((member t nil) (member t nil) + fixnum (array double-float (*)) + fixnum (array double-float (*)) + (double-float) (double-float) (array double-float (*)) + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::scale + nil nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::dladiv fortran-to-lisp::ddot + fortran-to-lisp::dlaln2 fortran-to-lisp::daxpy + fortran-to-lisp::dscal fortran-to-lisp::idamax + fortran-to-lisp::dasum fortran-to-lisp::dlange + fortran-to-lisp::dlamch)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlarfb LAPACK} +\pagehead{dlarfb}{dlarfb} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0)) + (declare (type (double-float 1.0 1.0) one)) + (defun dlarfb (side trans direct storev m n k v ldv t$ ldt c ldc work ldwork) + (declare (type (array double-float (*)) work c t$ v) + (type fixnum ldwork ldc ldt ldv k n m) + (type (simple-array character (*)) storev direct trans side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (trans character trans-%data% trans-%offset%) + (direct character direct-%data% direct-%offset%) + (storev character storev-%data% storev-%offset%) + (v double-float v-%data% v-%offset%) + (t$ double-float t$-%data% t$-%offset%) + (c double-float c-%data% c-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((i 0) (j 0) + (transt + (make-array '(1) :element-type 'character :initial-element #\ ))) + (declare (type fixnum i j) + (type (simple-array character (1)) transt)) + (if (or (<= m 0) (<= n 0)) (go end_label)) + (cond + ((lsame trans "N") + (f2cl-lib:f2cl-set-string transt "T" (string 1))) + (t + (f2cl-lib:f2cl-set-string transt "N" (string 1)))) + (cond + ((lsame storev "C") + (cond + ((lsame direct "F") + (cond + ((lsame side "L") + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (dcopy n + (f2cl-lib:array-slice c + double-float + (j 1) + ((1 ldc) (1 *))) + ldc + (f2cl-lib:array-slice work + double-float + (1 j) + ((1 ldwork) (1 *))) + 1))) + (dtrmm "Right" "Lower" "No transpose" "Unit" n k one v ldv + work ldwork) + (cond + ((> m k) + (dgemm "Transpose" "No transpose" n k + (f2cl-lib:int-sub m k) one + (f2cl-lib:array-slice c + double-float + ((+ k 1) 1) + ((1 ldc) (1 *))) + ldc + (f2cl-lib:array-slice v + double-float + ((+ k 1) 1) + ((1 ldv) (1 *))) + ldv one work ldwork))) + (dtrmm "Right" "Upper" transt "Non-unit" n k one t$ ldt work + ldwork) + (cond + ((> m k) + (dgemm "No transpose" "Transpose" (f2cl-lib:int-sub m k) n + k (- one) + (f2cl-lib:array-slice v + double-float + ((+ k 1) 1) + ((1 ldv) (1 *))) + ldv work ldwork one + (f2cl-lib:array-slice c + double-float + ((+ k 1) 1) + ((1 ldc) (1 *))) + ldc))) + (dtrmm "Right" "Lower" "Transpose" "Unit" n k one v ldv work + ldwork) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (j i) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j i) + ((1 ldc) (1 *)) + c-%offset%) + (f2cl-lib:fref work-%data% + (i j) + ((1 ldwork) (1 *)) + work-%offset%)))))))) + ((lsame side "R") + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (dcopy m + (f2cl-lib:array-slice c + double-float + (1 j) + ((1 ldc) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + (1 j) + ((1 ldwork) (1 *))) + 1))) + (dtrmm "Right" "Lower" "No transpose" "Unit" m k one v ldv + work ldwork) + (cond + ((> n k) + (dgemm "No transpose" "No transpose" m k + (f2cl-lib:int-sub n k) one + (f2cl-lib:array-slice c + double-float + (1 (f2cl-lib:int-add k 1)) + ((1 ldc) (1 *))) + ldc + (f2cl-lib:array-slice v + double-float + ((+ k 1) 1) + ((1 ldv) (1 *))) + ldv one work ldwork))) + (dtrmm "Right" "Upper" trans "Non-unit" m k one t$ ldt work + ldwork) + (cond + ((> n k) + (dgemm "No transpose" "Transpose" m (f2cl-lib:int-sub n k) + k (- one) work ldwork + (f2cl-lib:array-slice v + double-float + ((+ k 1) 1) + ((1 ldv) (1 *))) + ldv one + (f2cl-lib:array-slice c + double-float + (1 (f2cl-lib:int-add k 1)) + ((1 ldc) (1 *))) + ldc))) + (dtrmm "Right" "Lower" "Transpose" "Unit" m k one v ldv work + ldwork) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j k) 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%) + (- + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (f2cl-lib:fref work-%data% + (i j) + ((1 ldwork) (1 *)) + work-%offset%)))))))))) + (t + (cond + ((lsame side "L") + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (dcopy n + (f2cl-lib:array-slice c + double-float + ((+ m (f2cl-lib:int-sub k) j) 1) + ((1 ldc) (1 *))) + ldc + (f2cl-lib:array-slice work + double-float + (1 j) + ((1 ldwork) (1 *))) + 1))) + (dtrmm "Right" "Upper" "No transpose" "Unit" n k one + (f2cl-lib:array-slice v + double-float + ((+ m (f2cl-lib:int-sub k) 1) 1) + ((1 ldv) (1 *))) + ldv work ldwork) + (cond + ((> m k) + (dgemm "Transpose" "No transpose" n k + (f2cl-lib:int-sub m k) one c ldc v ldv one work ldwork))) + (dtrmm "Right" "Lower" transt "Non-unit" n k one t$ ldt work + ldwork) + (cond + ((> m k) + (dgemm "No transpose" "Transpose" (f2cl-lib:int-sub m k) n + k (- one) v ldv work ldwork one c ldc))) + (dtrmm "Right" "Upper" "Transpose" "Unit" n k one + (f2cl-lib:array-slice v + double-float + ((+ m (f2cl-lib:int-sub k) 1) 1) + ((1 ldv) (1 *))) + ldv work ldwork) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub m k) + j) + i) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub m k) + j) + i) + ((1 ldc) (1 *)) + c-%offset%) + (f2cl-lib:fref work-%data% + (i j) + ((1 ldwork) (1 *)) + work-%offset%)))))))) + ((lsame side "R") + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (dcopy m + (f2cl-lib:array-slice c + double-float + (1 + (f2cl-lib:int-add + (f2cl-lib:int-sub n k) + j)) + ((1 ldc) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + (1 j) + ((1 ldwork) (1 *))) + 1))) + (dtrmm "Right" "Upper" "No transpose" "Unit" m k one + (f2cl-lib:array-slice v + double-float + ((+ n (f2cl-lib:int-sub k) 1) 1) + ((1 ldv) (1 *))) + ldv work ldwork) + (cond + ((> n k) + (dgemm "No transpose" "No transpose" m k + (f2cl-lib:int-sub n k) one c ldc v ldv one work ldwork))) + (dtrmm "Right" "Lower" trans "Non-unit" m k one t$ ldt work + ldwork) + (cond + ((> n k) + (dgemm "No transpose" "Transpose" m (f2cl-lib:int-sub n k) + k (- one) work ldwork v ldv one c ldc))) + (dtrmm "Right" "Upper" "Transpose" "Unit" m k one + (f2cl-lib:array-slice v + double-float + ((+ n (f2cl-lib:int-sub k) 1) 1) + ((1 ldv) (1 *))) + ldv work ldwork) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i + (f2cl-lib:int-add + (f2cl-lib:int-sub n k) + j)) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (i + (f2cl-lib:int-add + (f2cl-lib:int-sub n k) + j)) + ((1 ldc) (1 *)) + c-%offset%) + (f2cl-lib:fref work-%data% + (i j) + ((1 ldwork) (1 *)) + work-%offset%)))))))))))) + ((lsame storev "R") + (cond + ((lsame direct "F") + (cond + ((lsame side "L") + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (dcopy n + (f2cl-lib:array-slice c + double-float + (j 1) + ((1 ldc) (1 *))) + ldc + (f2cl-lib:array-slice work + double-float + (1 j) + ((1 ldwork) (1 *))) + 1))) + (dtrmm "Right" "Upper" "Transpose" "Unit" n k one v ldv work + ldwork) + (cond + ((> m k) + (dgemm "Transpose" "Transpose" n k (f2cl-lib:int-sub m k) + one + (f2cl-lib:array-slice c + double-float + ((+ k 1) 1) + ((1 ldc) (1 *))) + ldc + (f2cl-lib:array-slice v + double-float + (1 (f2cl-lib:int-add k 1)) + ((1 ldv) (1 *))) + ldv one work ldwork))) + (dtrmm "Right" "Upper" transt "Non-unit" n k one t$ ldt work + ldwork) + (cond + ((> m k) + (dgemm "Transpose" "Transpose" (f2cl-lib:int-sub m k) n k + (- one) + (f2cl-lib:array-slice v + double-float + (1 (f2cl-lib:int-add k 1)) + ((1 ldv) (1 *))) + ldv work ldwork one + (f2cl-lib:array-slice c + double-float + ((+ k 1) 1) + ((1 ldc) (1 *))) + ldc))) + (dtrmm "Right" "Upper" "No transpose" "Unit" n k one v ldv + work ldwork) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (j i) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j i) + ((1 ldc) (1 *)) + c-%offset%) + (f2cl-lib:fref work-%data% + (i j) + ((1 ldwork) (1 *)) + work-%offset%)))))))) + ((lsame side "R") + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (dcopy m + (f2cl-lib:array-slice c + double-float + (1 j) + ((1 ldc) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + (1 j) + ((1 ldwork) (1 *))) + 1))) + (dtrmm "Right" "Upper" "Transpose" "Unit" m k one v ldv work + ldwork) + (cond + ((> n k) + (dgemm "No transpose" "Transpose" m k + (f2cl-lib:int-sub n k) one + (f2cl-lib:array-slice c + double-float + (1 (f2cl-lib:int-add k 1)) + ((1 ldc) (1 *))) + ldc + (f2cl-lib:array-slice v + double-float + (1 (f2cl-lib:int-add k 1)) + ((1 ldv) (1 *))) + ldv one work ldwork))) + (dtrmm "Right" "Upper" trans "Non-unit" m k one t$ ldt work + ldwork) + (cond + ((> n k) + (dgemm "No transpose" "No transpose" m + (f2cl-lib:int-sub n k) k (- one) work ldwork + (f2cl-lib:array-slice v + double-float + (1 (f2cl-lib:int-add k 1)) + ((1 ldv) (1 *))) + ldv one + (f2cl-lib:array-slice c + double-float + (1 (f2cl-lib:int-add k 1)) + ((1 ldc) (1 *))) + ldc))) + (dtrmm "Right" "Upper" "No transpose" "Unit" m k one v ldv + work ldwork) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j k) 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%) + (- + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (f2cl-lib:fref work-%data% + (i j) + ((1 ldwork) (1 *)) + work-%offset%)))))))))) + (t + (cond + ((lsame side "L") + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (dcopy n + (f2cl-lib:array-slice c + double-float + ((+ m (f2cl-lib:int-sub k) j) 1) + ((1 ldc) (1 *))) + ldc + (f2cl-lib:array-slice work + double-float + (1 j) + ((1 ldwork) (1 *))) + 1))) + (dtrmm "Right" "Lower" "Transpose" "Unit" n k one + (f2cl-lib:array-slice v + double-float + (1 + (f2cl-lib:int-add + (f2cl-lib:int-sub m k) + 1)) + ((1 ldv) (1 *))) + ldv work ldwork) + (cond + ((> m k) + (dgemm "Transpose" "Transpose" n k (f2cl-lib:int-sub m k) + one c ldc v ldv one work ldwork))) + (dtrmm "Right" "Lower" transt "Non-unit" n k one t$ ldt work + ldwork) + (cond + ((> m k) + (dgemm "Transpose" "Transpose" (f2cl-lib:int-sub m k) n k + (- one) v ldv work ldwork one c ldc))) + (dtrmm "Right" "Lower" "No transpose" "Unit" n k one + (f2cl-lib:array-slice v + double-float + (1 + (f2cl-lib:int-add + (f2cl-lib:int-sub m k) + 1)) + ((1 ldv) (1 *))) + ldv work ldwork) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub m k) + j) + i) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub m k) + j) + i) + ((1 ldc) (1 *)) + c-%offset%) + (f2cl-lib:fref work-%data% + (i j) + ((1 ldwork) (1 *)) + work-%offset%)))))))) + ((lsame side "R") + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (dcopy m + (f2cl-lib:array-slice c + double-float + (1 + (f2cl-lib:int-add + (f2cl-lib:int-sub n k) + j)) + ((1 ldc) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + (1 j) + ((1 ldwork) (1 *))) + 1))) + (dtrmm "Right" "Lower" "Transpose" "Unit" m k one + (f2cl-lib:array-slice v + double-float + (1 + (f2cl-lib:int-add + (f2cl-lib:int-sub n k) + 1)) + ((1 ldv) (1 *))) + ldv work ldwork) + (cond + ((> n k) + (dgemm "No transpose" "Transpose" m k + (f2cl-lib:int-sub n k) one c ldc v ldv one work ldwork))) + (dtrmm "Right" "Lower" trans "Non-unit" m k one t$ ldt work + ldwork) + (cond + ((> n k) + (dgemm "No transpose" "No transpose" m + (f2cl-lib:int-sub n k) k (- one) work ldwork v ldv one c + ldc))) + (dtrmm "Right" "Lower" "No transpose" "Unit" m k one + (f2cl-lib:array-slice v + double-float + (1 + (f2cl-lib:int-add + (f2cl-lib:int-sub n k) + 1)) + ((1 ldv) (1 *))) + ldv work ldwork) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i + (f2cl-lib:int-add + (f2cl-lib:int-sub n k) + j)) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (i + (f2cl-lib:int-add + (f2cl-lib:int-sub n k) + j)) + ((1 ldc) (1 *)) + c-%offset%) + (f2cl-lib:fref work-%data% + (i j) + ((1 ldwork) (1 *)) + work-%offset%))))))))))))) + end_label + (return + (values nil + nil + 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::dlarfb + 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 fixnum + fixnum (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 nil) + :calls '(fortran-to-lisp::dgemm fortran-to-lisp::dtrmm + fortran-to-lisp::dcopy fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlarfg LAPACK} +\pagehead{dlarfg}{dlarfg} +%\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 dlarfg (n alpha x incx tau) + (declare (type (array double-float (*)) x) + (type (double-float) tau alpha) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((x double-float x-%data% x-%offset%)) + (prog ((beta 0.0) (rsafmn 0.0) (safmin 0.0) (xnorm 0.0) (j 0) (knt 0)) + (declare (type (double-float) beta rsafmn safmin xnorm) + (type fixnum j knt)) + (cond + ((<= n 1) + (setf tau zero) + (go end_label))) + (setf xnorm (dnrm2 (f2cl-lib:int-sub n 1) x incx)) + (cond + ((= xnorm zero) + (setf tau zero)) + (t + (setf beta (- (f2cl-lib:sign (dlapy2 alpha xnorm) alpha))) + (setf safmin (/ (dlamch "S") (dlamch "E"))) + (cond + ((< (abs beta) safmin) + (tagbody + (setf rsafmn (/ one safmin)) + (setf knt 0) + label10 + (setf knt (f2cl-lib:int-add knt 1)) + (dscal (f2cl-lib:int-sub n 1) rsafmn x incx) + (setf beta (* beta rsafmn)) + (setf alpha (* alpha rsafmn)) + (if (< (abs beta) safmin) (go label10)) + (setf xnorm (dnrm2 (f2cl-lib:int-sub n 1) x incx)) + (setf beta (- (f2cl-lib:sign (dlapy2 alpha xnorm) alpha))) + (setf tau (/ (- beta alpha) beta)) + (dscal (f2cl-lib:int-sub n 1) (/ one (- alpha beta)) x incx) + (setf alpha beta) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j knt) nil) + (tagbody (setf alpha (* alpha safmin)) label20)))) + (t + (setf tau (/ (- beta alpha) beta)) + (dscal (f2cl-lib:int-sub n 1) (/ one (- alpha beta)) x incx) + (setf alpha beta))))) + end_label + (return (values nil alpha nil nil tau)))))) + +(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::dlarfg + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum (double-float) + (array double-float (*)) fixnum + (double-float)) + :return-values '(nil fortran-to-lisp::alpha nil nil + fortran-to-lisp::tau) + :calls '(fortran-to-lisp::dscal fortran-to-lisp::dlamch + fortran-to-lisp::dlapy2 fortran-to-lisp::dnrm2)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlarf LAPACK} +\pagehead{dlarf}{dlarf} +%\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 dlarf (side m n v incv tau c ldc work) + (declare (type (double-float) tau) + (type (array double-float (*)) work c v) + (type fixnum ldc incv n m) + (type (simple-array character (*)) side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (v double-float v-%data% v-%offset%) + (c double-float c-%data% c-%offset%) + (work double-float work-%data% work-%offset%)) + (prog () + (declare) + (cond + ((lsame side "L") + (cond + ((/= tau zero) + (dgemv "Transpose" m n one c ldc v incv zero work 1) + (dger m n (- tau) v incv work 1 c ldc)))) + (t + (cond + ((/= tau zero) + (dgemv "No transpose" m n one c ldc v incv zero work 1) + (dger m n (- tau) work 1 v incv c ldc))))) + (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::dlarf fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum fixnum + (array double-float (*)) fixnum + (double-float) (array double-float (*)) + fixnum (array double-float (*))) + :return-values '(nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::dger fortran-to-lisp::dgemv + fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlarft LAPACK} +\pagehead{dlarft}{dlarft} +%\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 dlarft (direct storev n k v ldv tau t$ ldt) + (declare (type (array double-float (*)) t$ tau v) + (type fixnum ldt ldv k n) + (type (simple-array character (*)) storev direct)) + (f2cl-lib:with-multi-array-data + ((direct character direct-%data% direct-%offset%) + (storev character storev-%data% storev-%offset%) + (v double-float v-%data% v-%offset%) + (tau double-float tau-%data% tau-%offset%) + (t$ double-float t$-%data% t$-%offset%)) + (prog ((vii 0.0) (i 0) (j 0)) + (declare (type (double-float) vii) (type fixnum i j)) + (if (= n 0) (go end_label)) + (cond + ((lsame direct "F") + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i k) nil) + (tagbody + (cond + ((= (f2cl-lib:fref tau (i) ((1 *))) zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j i) nil) + (tagbody + (setf (f2cl-lib:fref t$-%data% + (j i) + ((1 ldt) (1 *)) + t$-%offset%) + zero)))) + (t + (setf vii + (f2cl-lib:fref v-%data% + (i i) + ((1 ldv) (1 *)) + v-%offset%)) + (setf (f2cl-lib:fref v-%data% + (i i) + ((1 ldv) (1 *)) + v-%offset%) + one) + (cond + ((lsame storev "C") + (dgemv "Transpose" + (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1) + (f2cl-lib:int-sub i 1) + (- (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%)) + (f2cl-lib:array-slice v + double-float + (i 1) + ((1 ldv) (1 *))) + ldv + (f2cl-lib:array-slice v + double-float + (i i) + ((1 ldv) (1 *))) + 1 zero + (f2cl-lib:array-slice t$ + double-float + (1 i) + ((1 ldt) (1 *))) + 1)) + (t + (dgemv "No transpose" (f2cl-lib:int-sub i 1) + (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1) + (- (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%)) + (f2cl-lib:array-slice v + double-float + (1 i) + ((1 ldv) (1 *))) + ldv + (f2cl-lib:array-slice v + double-float + (i i) + ((1 ldv) (1 *))) + ldv zero + (f2cl-lib:array-slice t$ + double-float + (1 i) + ((1 ldt) (1 *))) + 1))) + (setf (f2cl-lib:fref v-%data% + (i i) + ((1 ldv) (1 *)) + v-%offset%) + vii) + (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 *))) + 1) + (setf (f2cl-lib:fref t$-%data% + (i i) + ((1 ldt) (1 *)) + t$-%offset%) + (f2cl-lib:fref tau-%data% + (i) + ((1 *)) + tau-%offset%))))))) + (t + (f2cl-lib:fdo (i k (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (cond + ((= (f2cl-lib:fref tau (i) ((1 *))) zero) + (f2cl-lib:fdo (j i (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (setf (f2cl-lib:fref t$-%data% + (j i) + ((1 ldt) (1 *)) + t$-%offset%) + zero)))) + (t + (cond + ((< i k) + (cond + ((lsame storev "C") + (setf vii + (f2cl-lib:fref v-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub n k) + i) + i) + ((1 ldv) (1 *)) + v-%offset%)) + (setf (f2cl-lib:fref v-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub n k) + i) + i) + ((1 ldv) (1 *)) + v-%offset%) + one) + (dgemv "Transpose" + (f2cl-lib:int-add (f2cl-lib:int-sub n k) i) + (f2cl-lib:int-sub k i) + (- + (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%)) + (f2cl-lib:array-slice v + double-float + (1 (f2cl-lib:int-add i 1)) + ((1 ldv) (1 *))) + ldv + (f2cl-lib:array-slice v + double-float + (1 i) + ((1 ldv) (1 *))) + 1 zero + (f2cl-lib:array-slice t$ + double-float + ((+ i 1) i) + ((1 ldt) (1 *))) + 1) + (setf (f2cl-lib:fref v-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub n k) + i) + i) + ((1 ldv) (1 *)) + v-%offset%) + vii)) + (t + (setf vii + (f2cl-lib:fref v-%data% + (i + (f2cl-lib:int-add + (f2cl-lib:int-sub n k) + i)) + ((1 ldv) (1 *)) + v-%offset%)) + (setf (f2cl-lib:fref v-%data% + (i + (f2cl-lib:int-add + (f2cl-lib:int-sub n k) + i)) + ((1 ldv) (1 *)) + v-%offset%) + one) + (dgemv "No transpose" (f2cl-lib:int-sub k i) + (f2cl-lib:int-add (f2cl-lib:int-sub n k) i) + (- + (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%)) + (f2cl-lib:array-slice v + double-float + ((+ i 1) 1) + ((1 ldv) (1 *))) + ldv + (f2cl-lib:array-slice v + double-float + (i 1) + ((1 ldv) (1 *))) + ldv zero + (f2cl-lib:array-slice t$ + double-float + ((+ i 1) i) + ((1 ldt) (1 *))) + 1) + (setf (f2cl-lib:fref v-%data% + (i + (f2cl-lib:int-add + (f2cl-lib:int-sub n k) + i)) + ((1 ldv) (1 *)) + v-%offset%) + vii))) + (dtrmv "Lower" "No transpose" "Non-unit" + (f2cl-lib:int-sub k i) + (f2cl-lib:array-slice t$ + double-float + ((+ i 1) (f2cl-lib:int-add i 1)) + ((1 ldt) (1 *))) + ldt + (f2cl-lib:array-slice t$ + double-float + ((+ i 1) i) + ((1 ldt) (1 *))) + 1))) + (setf (f2cl-lib:fref t$-%data% + (i i) + ((1 ldt) (1 *)) + t$-%offset%) + (f2cl-lib:fref tau-%data% + (i) + ((1 *)) + tau-%offset%)))))))) + 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::dlarft + 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) + :return-values '(nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::dtrmv fortran-to-lisp::dgemv + fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlarfx LAPACK} +\pagehead{dlarfx}{dlarfx} +%\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 dlarfx (side m n v tau c ldc work) + (declare (type (double-float) tau) + (type (array double-float (*)) work c v) + (type fixnum ldc n m) + (type (simple-array character (*)) side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (v double-float v-%data% v-%offset%) + (c double-float c-%data% c-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((sum 0.0) (t1 0.0) (t10 0.0) (t2 0.0) (t3 0.0) (t4 0.0) (t5 0.0) + (t6 0.0) (t7 0.0) (t8 0.0) (t9 0.0) (v1 0.0) (v10 0.0) (v2 0.0) + (v3 0.0) (v4 0.0) (v5 0.0) (v6 0.0) (v7 0.0) (v8 0.0) (v9 0.0) + (j 0)) + (declare (type (double-float) sum t1 t10 t2 t3 t4 t5 t6 t7 t8 t9 v1 v10 + v2 v3 v4 v5 v6 v7 v8 v9) + (type fixnum j)) + (if (= tau zero) (go end_label)) + (cond + ((lsame side "L") + (tagbody + (f2cl-lib:computed-goto + (label10 label30 label50 label70 label90 label110 label130 + label150 label170 label190) + m) + (dgemv "Transpose" m n one c ldc v 1 zero work 1) + (dger m n (- tau) v 1 work 1 c ldc) + (go end_label) + label10 + (setf t1 + (+ one + (* (- tau) + (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%) + (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%) + (* t1 + (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%))))) + (go end_label) + label30 + (setf v1 (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)) + (setf t1 (* tau v1)) + (setf v2 (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)) + (setf t2 (* tau v2)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf sum + (+ + (* v1 + (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v2 + (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%)))) + (setf (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t2))))) + (go end_label) + label50 + (setf v1 (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)) + (setf t1 (* tau v1)) + (setf v2 (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)) + (setf t2 (* tau v2)) + (setf v3 (f2cl-lib:fref v-%data% (3) ((1 *)) v-%offset%)) + (setf t3 (* tau v3)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf sum + (+ + (* v1 + (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v2 + (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v3 + (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%)))) + (setf (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t2))) + (setf (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t3))))) + (go end_label) + label70 + (setf v1 (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)) + (setf t1 (* tau v1)) + (setf v2 (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)) + (setf t2 (* tau v2)) + (setf v3 (f2cl-lib:fref v-%data% (3) ((1 *)) v-%offset%)) + (setf t3 (* tau v3)) + (setf v4 (f2cl-lib:fref v-%data% (4) ((1 *)) v-%offset%)) + (setf t4 (* tau v4)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf sum + (+ + (* v1 + (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v2 + (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v3 + (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v4 + (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%)))) + (setf (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t2))) + (setf (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t3))) + (setf (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t4))))) + (go end_label) + label90 + (setf v1 (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)) + (setf t1 (* tau v1)) + (setf v2 (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)) + (setf t2 (* tau v2)) + (setf v3 (f2cl-lib:fref v-%data% (3) ((1 *)) v-%offset%)) + (setf t3 (* tau v3)) + (setf v4 (f2cl-lib:fref v-%data% (4) ((1 *)) v-%offset%)) + (setf t4 (* tau v4)) + (setf v5 (f2cl-lib:fref v-%data% (5) ((1 *)) v-%offset%)) + (setf t5 (* tau v5)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf sum + (+ + (* v1 + (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v2 + (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v3 + (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v4 + (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v5 + (f2cl-lib:fref c-%data% + (5 j) + ((1 ldc) (1 *)) + c-%offset%)))) + (setf (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t2))) + (setf (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t3))) + (setf (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t4))) + (setf (f2cl-lib:fref c-%data% + (5 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (5 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t5))))) + (go end_label) + label110 + (setf v1 (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)) + (setf t1 (* tau v1)) + (setf v2 (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)) + (setf t2 (* tau v2)) + (setf v3 (f2cl-lib:fref v-%data% (3) ((1 *)) v-%offset%)) + (setf t3 (* tau v3)) + (setf v4 (f2cl-lib:fref v-%data% (4) ((1 *)) v-%offset%)) + (setf t4 (* tau v4)) + (setf v5 (f2cl-lib:fref v-%data% (5) ((1 *)) v-%offset%)) + (setf t5 (* tau v5)) + (setf v6 (f2cl-lib:fref v-%data% (6) ((1 *)) v-%offset%)) + (setf t6 (* tau v6)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf sum + (+ + (* v1 + (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v2 + (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v3 + (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v4 + (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v5 + (f2cl-lib:fref c-%data% + (5 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v6 + (f2cl-lib:fref c-%data% + (6 j) + ((1 ldc) (1 *)) + c-%offset%)))) + (setf (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t2))) + (setf (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t3))) + (setf (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t4))) + (setf (f2cl-lib:fref c-%data% + (5 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (5 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t5))) + (setf (f2cl-lib:fref c-%data% + (6 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (6 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t6))))) + (go end_label) + label130 + (setf v1 (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)) + (setf t1 (* tau v1)) + (setf v2 (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)) + (setf t2 (* tau v2)) + (setf v3 (f2cl-lib:fref v-%data% (3) ((1 *)) v-%offset%)) + (setf t3 (* tau v3)) + (setf v4 (f2cl-lib:fref v-%data% (4) ((1 *)) v-%offset%)) + (setf t4 (* tau v4)) + (setf v5 (f2cl-lib:fref v-%data% (5) ((1 *)) v-%offset%)) + (setf t5 (* tau v5)) + (setf v6 (f2cl-lib:fref v-%data% (6) ((1 *)) v-%offset%)) + (setf t6 (* tau v6)) + (setf v7 (f2cl-lib:fref v-%data% (7) ((1 *)) v-%offset%)) + (setf t7 (* tau v7)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf sum + (+ + (* v1 + (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v2 + (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v3 + (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v4 + (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v5 + (f2cl-lib:fref c-%data% + (5 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v6 + (f2cl-lib:fref c-%data% + (6 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v7 + (f2cl-lib:fref c-%data% + (7 j) + ((1 ldc) (1 *)) + c-%offset%)))) + (setf (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t2))) + (setf (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t3))) + (setf (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t4))) + (setf (f2cl-lib:fref c-%data% + (5 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (5 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t5))) + (setf (f2cl-lib:fref c-%data% + (6 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (6 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t6))) + (setf (f2cl-lib:fref c-%data% + (7 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (7 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t7))))) + (go end_label) + label150 + (setf v1 (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)) + (setf t1 (* tau v1)) + (setf v2 (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)) + (setf t2 (* tau v2)) + (setf v3 (f2cl-lib:fref v-%data% (3) ((1 *)) v-%offset%)) + (setf t3 (* tau v3)) + (setf v4 (f2cl-lib:fref v-%data% (4) ((1 *)) v-%offset%)) + (setf t4 (* tau v4)) + (setf v5 (f2cl-lib:fref v-%data% (5) ((1 *)) v-%offset%)) + (setf t5 (* tau v5)) + (setf v6 (f2cl-lib:fref v-%data% (6) ((1 *)) v-%offset%)) + (setf t6 (* tau v6)) + (setf v7 (f2cl-lib:fref v-%data% (7) ((1 *)) v-%offset%)) + (setf t7 (* tau v7)) + (setf v8 (f2cl-lib:fref v-%data% (8) ((1 *)) v-%offset%)) + (setf t8 (* tau v8)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf sum + (+ + (* v1 + (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v2 + (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v3 + (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v4 + (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v5 + (f2cl-lib:fref c-%data% + (5 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v6 + (f2cl-lib:fref c-%data% + (6 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v7 + (f2cl-lib:fref c-%data% + (7 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v8 + (f2cl-lib:fref c-%data% + (8 j) + ((1 ldc) (1 *)) + c-%offset%)))) + (setf (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t2))) + (setf (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t3))) + (setf (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t4))) + (setf (f2cl-lib:fref c-%data% + (5 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (5 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t5))) + (setf (f2cl-lib:fref c-%data% + (6 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (6 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t6))) + (setf (f2cl-lib:fref c-%data% + (7 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (7 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t7))) + (setf (f2cl-lib:fref c-%data% + (8 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (8 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t8))))) + (go end_label) + label170 + (setf v1 (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)) + (setf t1 (* tau v1)) + (setf v2 (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)) + (setf t2 (* tau v2)) + (setf v3 (f2cl-lib:fref v-%data% (3) ((1 *)) v-%offset%)) + (setf t3 (* tau v3)) + (setf v4 (f2cl-lib:fref v-%data% (4) ((1 *)) v-%offset%)) + (setf t4 (* tau v4)) + (setf v5 (f2cl-lib:fref v-%data% (5) ((1 *)) v-%offset%)) + (setf t5 (* tau v5)) + (setf v6 (f2cl-lib:fref v-%data% (6) ((1 *)) v-%offset%)) + (setf t6 (* tau v6)) + (setf v7 (f2cl-lib:fref v-%data% (7) ((1 *)) v-%offset%)) + (setf t7 (* tau v7)) + (setf v8 (f2cl-lib:fref v-%data% (8) ((1 *)) v-%offset%)) + (setf t8 (* tau v8)) + (setf v9 (f2cl-lib:fref v-%data% (9) ((1 *)) v-%offset%)) + (setf t9 (* tau v9)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf sum + (+ + (* v1 + (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v2 + (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v3 + (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v4 + (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v5 + (f2cl-lib:fref c-%data% + (5 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v6 + (f2cl-lib:fref c-%data% + (6 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v7 + (f2cl-lib:fref c-%data% + (7 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v8 + (f2cl-lib:fref c-%data% + (8 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v9 + (f2cl-lib:fref c-%data% + (9 j) + ((1 ldc) (1 *)) + c-%offset%)))) + (setf (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t2))) + (setf (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t3))) + (setf (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t4))) + (setf (f2cl-lib:fref c-%data% + (5 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (5 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t5))) + (setf (f2cl-lib:fref c-%data% + (6 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (6 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t6))) + (setf (f2cl-lib:fref c-%data% + (7 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (7 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t7))) + (setf (f2cl-lib:fref c-%data% + (8 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (8 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t8))) + (setf (f2cl-lib:fref c-%data% + (9 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (9 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t9))))) + (go end_label) + label190 + (setf v1 (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)) + (setf t1 (* tau v1)) + (setf v2 (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)) + (setf t2 (* tau v2)) + (setf v3 (f2cl-lib:fref v-%data% (3) ((1 *)) v-%offset%)) + (setf t3 (* tau v3)) + (setf v4 (f2cl-lib:fref v-%data% (4) ((1 *)) v-%offset%)) + (setf t4 (* tau v4)) + (setf v5 (f2cl-lib:fref v-%data% (5) ((1 *)) v-%offset%)) + (setf t5 (* tau v5)) + (setf v6 (f2cl-lib:fref v-%data% (6) ((1 *)) v-%offset%)) + (setf t6 (* tau v6)) + (setf v7 (f2cl-lib:fref v-%data% (7) ((1 *)) v-%offset%)) + (setf t7 (* tau v7)) + (setf v8 (f2cl-lib:fref v-%data% (8) ((1 *)) v-%offset%)) + (setf t8 (* tau v8)) + (setf v9 (f2cl-lib:fref v-%data% (9) ((1 *)) v-%offset%)) + (setf t9 (* tau v9)) + (setf v10 (f2cl-lib:fref v-%data% (10) ((1 *)) v-%offset%)) + (setf t10 (* tau v10)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf sum + (+ + (* v1 + (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v2 + (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v3 + (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v4 + (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v5 + (f2cl-lib:fref c-%data% + (5 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v6 + (f2cl-lib:fref c-%data% + (6 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v7 + (f2cl-lib:fref c-%data% + (7 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v8 + (f2cl-lib:fref c-%data% + (8 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v9 + (f2cl-lib:fref c-%data% + (9 j) + ((1 ldc) (1 *)) + c-%offset%)) + (* v10 + (f2cl-lib:fref c-%data% + (10 j) + ((1 ldc) (1 *)) + c-%offset%)))) + (setf (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (1 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (2 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t2))) + (setf (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (3 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t3))) + (setf (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (4 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t4))) + (setf (f2cl-lib:fref c-%data% + (5 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (5 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t5))) + (setf (f2cl-lib:fref c-%data% + (6 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (6 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t6))) + (setf (f2cl-lib:fref c-%data% + (7 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (7 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t7))) + (setf (f2cl-lib:fref c-%data% + (8 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (8 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t8))) + (setf (f2cl-lib:fref c-%data% + (9 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (9 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t9))) + (setf (f2cl-lib:fref c-%data% + (10 j) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (10 j) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t10))))) + (go end_label))) + (t + (tagbody + (f2cl-lib:computed-goto + (label210 label230 label250 label270 label290 label310 label330 + label350 label370 label390) + n) + (dgemv "No transpose" m n one c ldc v 1 zero work 1) + (dger m n (- tau) work 1 v 1 c ldc) + (go end_label) + label210 + (setf t1 + (+ one + (* (- tau) + (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%) + (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%) + (* t1 + (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%))))) + (go end_label) + label230 + (setf v1 (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)) + (setf t1 (* tau v1)) + (setf v2 (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)) + (setf t2 (* tau v2)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j m) nil) + (tagbody + (setf sum + (+ + (* v1 + (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%)) + (* v2 + (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%)))) + (setf (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t2))))) + (go end_label) + label250 + (setf v1 (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)) + (setf t1 (* tau v1)) + (setf v2 (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)) + (setf t2 (* tau v2)) + (setf v3 (f2cl-lib:fref v-%data% (3) ((1 *)) v-%offset%)) + (setf t3 (* tau v3)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j m) nil) + (tagbody + (setf sum + (+ + (* v1 + (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%)) + (* v2 + (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%)) + (* v3 + (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%)))) + (setf (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t2))) + (setf (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t3))))) + (go end_label) + label270 + (setf v1 (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)) + (setf t1 (* tau v1)) + (setf v2 (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)) + (setf t2 (* tau v2)) + (setf v3 (f2cl-lib:fref v-%data% (3) ((1 *)) v-%offset%)) + (setf t3 (* tau v3)) + (setf v4 (f2cl-lib:fref v-%data% (4) ((1 *)) v-%offset%)) + (setf t4 (* tau v4)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j m) nil) + (tagbody + (setf sum + (+ + (* v1 + (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%)) + (* v2 + (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%)) + (* v3 + (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%)) + (* v4 + (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%)))) + (setf (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t2))) + (setf (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t3))) + (setf (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t4))))) + (go end_label) + label290 + (setf v1 (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)) + (setf t1 (* tau v1)) + (setf v2 (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)) + (setf t2 (* tau v2)) + (setf v3 (f2cl-lib:fref v-%data% (3) ((1 *)) v-%offset%)) + (setf t3 (* tau v3)) + (setf v4 (f2cl-lib:fref v-%data% (4) ((1 *)) v-%offset%)) + (setf t4 (* tau v4)) + (setf v5 (f2cl-lib:fref v-%data% (5) ((1 *)) v-%offset%)) + (setf t5 (* tau v5)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j m) nil) + (tagbody + (setf sum + (+ + (* v1 + (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%)) + (* v2 + (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%)) + (* v3 + (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%)) + (* v4 + (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%)) + (* v5 + (f2cl-lib:fref c-%data% + (j 5) + ((1 ldc) (1 *)) + c-%offset%)))) + (setf (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t2))) + (setf (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t3))) + (setf (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t4))) + (setf (f2cl-lib:fref c-%data% + (j 5) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 5) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t5))))) + (go end_label) + label310 + (setf v1 (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)) + (setf t1 (* tau v1)) + (setf v2 (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)) + (setf t2 (* tau v2)) + (setf v3 (f2cl-lib:fref v-%data% (3) ((1 *)) v-%offset%)) + (setf t3 (* tau v3)) + (setf v4 (f2cl-lib:fref v-%data% (4) ((1 *)) v-%offset%)) + (setf t4 (* tau v4)) + (setf v5 (f2cl-lib:fref v-%data% (5) ((1 *)) v-%offset%)) + (setf t5 (* tau v5)) + (setf v6 (f2cl-lib:fref v-%data% (6) ((1 *)) v-%offset%)) + (setf t6 (* tau v6)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j m) nil) + (tagbody + (setf sum + (+ + (* v1 + (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%)) + (* v2 + (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%)) + (* v3 + (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%)) + (* v4 + (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%)) + (* v5 + (f2cl-lib:fref c-%data% + (j 5) + ((1 ldc) (1 *)) + c-%offset%)) + (* v6 + (f2cl-lib:fref c-%data% + (j 6) + ((1 ldc) (1 *)) + c-%offset%)))) + (setf (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t2))) + (setf (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t3))) + (setf (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t4))) + (setf (f2cl-lib:fref c-%data% + (j 5) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 5) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t5))) + (setf (f2cl-lib:fref c-%data% + (j 6) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 6) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t6))))) + (go end_label) + label330 + (setf v1 (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)) + (setf t1 (* tau v1)) + (setf v2 (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)) + (setf t2 (* tau v2)) + (setf v3 (f2cl-lib:fref v-%data% (3) ((1 *)) v-%offset%)) + (setf t3 (* tau v3)) + (setf v4 (f2cl-lib:fref v-%data% (4) ((1 *)) v-%offset%)) + (setf t4 (* tau v4)) + (setf v5 (f2cl-lib:fref v-%data% (5) ((1 *)) v-%offset%)) + (setf t5 (* tau v5)) + (setf v6 (f2cl-lib:fref v-%data% (6) ((1 *)) v-%offset%)) + (setf t6 (* tau v6)) + (setf v7 (f2cl-lib:fref v-%data% (7) ((1 *)) v-%offset%)) + (setf t7 (* tau v7)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j m) nil) + (tagbody + (setf sum + (+ + (* v1 + (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%)) + (* v2 + (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%)) + (* v3 + (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%)) + (* v4 + (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%)) + (* v5 + (f2cl-lib:fref c-%data% + (j 5) + ((1 ldc) (1 *)) + c-%offset%)) + (* v6 + (f2cl-lib:fref c-%data% + (j 6) + ((1 ldc) (1 *)) + c-%offset%)) + (* v7 + (f2cl-lib:fref c-%data% + (j 7) + ((1 ldc) (1 *)) + c-%offset%)))) + (setf (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t2))) + (setf (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t3))) + (setf (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t4))) + (setf (f2cl-lib:fref c-%data% + (j 5) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 5) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t5))) + (setf (f2cl-lib:fref c-%data% + (j 6) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 6) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t6))) + (setf (f2cl-lib:fref c-%data% + (j 7) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 7) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t7))))) + (go end_label) + label350 + (setf v1 (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)) + (setf t1 (* tau v1)) + (setf v2 (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)) + (setf t2 (* tau v2)) + (setf v3 (f2cl-lib:fref v-%data% (3) ((1 *)) v-%offset%)) + (setf t3 (* tau v3)) + (setf v4 (f2cl-lib:fref v-%data% (4) ((1 *)) v-%offset%)) + (setf t4 (* tau v4)) + (setf v5 (f2cl-lib:fref v-%data% (5) ((1 *)) v-%offset%)) + (setf t5 (* tau v5)) + (setf v6 (f2cl-lib:fref v-%data% (6) ((1 *)) v-%offset%)) + (setf t6 (* tau v6)) + (setf v7 (f2cl-lib:fref v-%data% (7) ((1 *)) v-%offset%)) + (setf t7 (* tau v7)) + (setf v8 (f2cl-lib:fref v-%data% (8) ((1 *)) v-%offset%)) + (setf t8 (* tau v8)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j m) nil) + (tagbody + (setf sum + (+ + (* v1 + (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%)) + (* v2 + (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%)) + (* v3 + (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%)) + (* v4 + (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%)) + (* v5 + (f2cl-lib:fref c-%data% + (j 5) + ((1 ldc) (1 *)) + c-%offset%)) + (* v6 + (f2cl-lib:fref c-%data% + (j 6) + ((1 ldc) (1 *)) + c-%offset%)) + (* v7 + (f2cl-lib:fref c-%data% + (j 7) + ((1 ldc) (1 *)) + c-%offset%)) + (* v8 + (f2cl-lib:fref c-%data% + (j 8) + ((1 ldc) (1 *)) + c-%offset%)))) + (setf (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t2))) + (setf (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t3))) + (setf (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t4))) + (setf (f2cl-lib:fref c-%data% + (j 5) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 5) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t5))) + (setf (f2cl-lib:fref c-%data% + (j 6) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 6) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t6))) + (setf (f2cl-lib:fref c-%data% + (j 7) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 7) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t7))) + (setf (f2cl-lib:fref c-%data% + (j 8) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 8) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t8))))) + (go end_label) + label370 + (setf v1 (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)) + (setf t1 (* tau v1)) + (setf v2 (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)) + (setf t2 (* tau v2)) + (setf v3 (f2cl-lib:fref v-%data% (3) ((1 *)) v-%offset%)) + (setf t3 (* tau v3)) + (setf v4 (f2cl-lib:fref v-%data% (4) ((1 *)) v-%offset%)) + (setf t4 (* tau v4)) + (setf v5 (f2cl-lib:fref v-%data% (5) ((1 *)) v-%offset%)) + (setf t5 (* tau v5)) + (setf v6 (f2cl-lib:fref v-%data% (6) ((1 *)) v-%offset%)) + (setf t6 (* tau v6)) + (setf v7 (f2cl-lib:fref v-%data% (7) ((1 *)) v-%offset%)) + (setf t7 (* tau v7)) + (setf v8 (f2cl-lib:fref v-%data% (8) ((1 *)) v-%offset%)) + (setf t8 (* tau v8)) + (setf v9 (f2cl-lib:fref v-%data% (9) ((1 *)) v-%offset%)) + (setf t9 (* tau v9)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j m) nil) + (tagbody + (setf sum + (+ + (* v1 + (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%)) + (* v2 + (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%)) + (* v3 + (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%)) + (* v4 + (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%)) + (* v5 + (f2cl-lib:fref c-%data% + (j 5) + ((1 ldc) (1 *)) + c-%offset%)) + (* v6 + (f2cl-lib:fref c-%data% + (j 6) + ((1 ldc) (1 *)) + c-%offset%)) + (* v7 + (f2cl-lib:fref c-%data% + (j 7) + ((1 ldc) (1 *)) + c-%offset%)) + (* v8 + (f2cl-lib:fref c-%data% + (j 8) + ((1 ldc) (1 *)) + c-%offset%)) + (* v9 + (f2cl-lib:fref c-%data% + (j 9) + ((1 ldc) (1 *)) + c-%offset%)))) + (setf (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t2))) + (setf (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t3))) + (setf (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t4))) + (setf (f2cl-lib:fref c-%data% + (j 5) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 5) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t5))) + (setf (f2cl-lib:fref c-%data% + (j 6) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 6) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t6))) + (setf (f2cl-lib:fref c-%data% + (j 7) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 7) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t7))) + (setf (f2cl-lib:fref c-%data% + (j 8) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 8) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t8))) + (setf (f2cl-lib:fref c-%data% + (j 9) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 9) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t9))))) + (go end_label) + label390 + (setf v1 (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)) + (setf t1 (* tau v1)) + (setf v2 (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)) + (setf t2 (* tau v2)) + (setf v3 (f2cl-lib:fref v-%data% (3) ((1 *)) v-%offset%)) + (setf t3 (* tau v3)) + (setf v4 (f2cl-lib:fref v-%data% (4) ((1 *)) v-%offset%)) + (setf t4 (* tau v4)) + (setf v5 (f2cl-lib:fref v-%data% (5) ((1 *)) v-%offset%)) + (setf t5 (* tau v5)) + (setf v6 (f2cl-lib:fref v-%data% (6) ((1 *)) v-%offset%)) + (setf t6 (* tau v6)) + (setf v7 (f2cl-lib:fref v-%data% (7) ((1 *)) v-%offset%)) + (setf t7 (* tau v7)) + (setf v8 (f2cl-lib:fref v-%data% (8) ((1 *)) v-%offset%)) + (setf t8 (* tau v8)) + (setf v9 (f2cl-lib:fref v-%data% (9) ((1 *)) v-%offset%)) + (setf t9 (* tau v9)) + (setf v10 (f2cl-lib:fref v-%data% (10) ((1 *)) v-%offset%)) + (setf t10 (* tau v10)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j m) nil) + (tagbody + (setf sum + (+ + (* v1 + (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%)) + (* v2 + (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%)) + (* v3 + (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%)) + (* v4 + (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%)) + (* v5 + (f2cl-lib:fref c-%data% + (j 5) + ((1 ldc) (1 *)) + c-%offset%)) + (* v6 + (f2cl-lib:fref c-%data% + (j 6) + ((1 ldc) (1 *)) + c-%offset%)) + (* v7 + (f2cl-lib:fref c-%data% + (j 7) + ((1 ldc) (1 *)) + c-%offset%)) + (* v8 + (f2cl-lib:fref c-%data% + (j 8) + ((1 ldc) (1 *)) + c-%offset%)) + (* v9 + (f2cl-lib:fref c-%data% + (j 9) + ((1 ldc) (1 *)) + c-%offset%)) + (* v10 + (f2cl-lib:fref c-%data% + (j 10) + ((1 ldc) (1 *)) + c-%offset%)))) + (setf (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 1) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t1))) + (setf (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 2) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t2))) + (setf (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 3) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t3))) + (setf (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 4) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t4))) + (setf (f2cl-lib:fref c-%data% + (j 5) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 5) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t5))) + (setf (f2cl-lib:fref c-%data% + (j 6) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 6) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t6))) + (setf (f2cl-lib:fref c-%data% + (j 7) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 7) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t7))) + (setf (f2cl-lib:fref c-%data% + (j 8) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 8) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t8))) + (setf (f2cl-lib:fref c-%data% + (j 9) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 9) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t9))) + (setf (f2cl-lib:fref c-%data% + (j 10) + ((1 ldc) (1 *)) + c-%offset%) + (- + (f2cl-lib:fref c-%data% + (j 10) + ((1 ldc) (1 *)) + c-%offset%) + (* sum t10))))) + (go end_label)))) + end_label + (return (values 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::dlarfx + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum fixnum + (array double-float (*)) (double-float) + (array double-float (*)) fixnum + (array double-float (*))) + :return-values '(nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::dger fortran-to-lisp::dgemv + fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlartg LAPACK} +\pagehead{dlartg}{dlartg} +%\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 ((safmx2 0.0) (safmin 0.0) (safmn2 0.0) (first$ nil)) + (declare (type (member t nil) first$) + (type (double-float) safmn2 safmin safmx2)) + (setq first$ t) + (defun dlartg (f g cs sn r) + (declare (type (double-float) r sn cs g f)) + (prog ((eps 0.0) (f1 0.0) (g1 0.0) (scale 0.0) (i 0) (count$ 0)) + (declare (type (double-float) eps f1 g1 scale) + (type fixnum count$ i)) + (cond + (first$ + (setf first$ nil) + (setf safmin (dlamch "S")) + (setf eps (dlamch "E")) + (setf safmn2 + (expt (dlamch "B") + (f2cl-lib:int + (/ + (/ (f2cl-lib:flog (/ safmin eps)) + (f2cl-lib:flog (dlamch "B"))) + two)))) + (setf safmx2 (/ one safmn2)))) + (cond + ((= g zero) + (setf cs one) + (setf sn zero) + (setf r f)) + ((= f zero) + (setf cs zero) + (setf sn one) + (setf r g)) + (t + (setf f1 f) + (setf g1 g) + (setf scale (max (abs f1) (abs g1))) + (cond + ((>= scale safmx2) + (tagbody + (setf count$ 0) + label10 + (setf count$ (f2cl-lib:int-add count$ 1)) + (setf f1 (* f1 safmn2)) + (setf g1 (* g1 safmn2)) + (setf scale (max (abs f1) (abs g1))) + (if (>= scale safmx2) (go label10)) + (setf r (f2cl-lib:fsqrt (+ (expt f1 2) (expt g1 2)))) + (setf cs (/ f1 r)) + (setf sn (/ g1 r)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i count$) nil) + (tagbody (setf r (* r safmx2)) label20)))) + ((<= scale safmn2) + (tagbody + (setf count$ 0) + label30 + (setf count$ (f2cl-lib:int-add count$ 1)) + (setf f1 (* f1 safmx2)) + (setf g1 (* g1 safmx2)) + (setf scale (max (abs f1) (abs g1))) + (if (<= scale safmn2) (go label30)) + (setf r (f2cl-lib:fsqrt (+ (expt f1 2) (expt g1 2)))) + (setf cs (/ f1 r)) + (setf sn (/ g1 r)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i count$) nil) + (tagbody (setf r (* r safmn2)) label40)))) + (t + (setf r (f2cl-lib:fsqrt (+ (expt f1 2) (expt g1 2)))) + (setf cs (/ f1 r)) + (setf sn (/ g1 r)))) + (cond + ((and (> (abs f) (abs g)) (< cs zero)) + (setf cs (- cs)) + (setf sn (- sn)) + (setf r (- r)))))) + end_label + (return (values nil nil cs sn r)))))) + +(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::dlartg + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((double-float) (double-float) (double-float) + (double-float) (double-float)) + :return-values '(nil nil fortran-to-lisp::cs fortran-to-lisp::sn + fortran-to-lisp::r) + :calls '(fortran-to-lisp::dlamch)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlas2 LAPACK} +\pagehead{dlas2}{dlas2} +%\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)) + (defun dlas2 (f g h ssmin ssmax) + (declare (type (double-float) ssmax ssmin h g f)) + (prog ((as 0.0) (at 0.0) (au 0.0) (c 0.0) (fa 0.0) (fhmn 0.0) (fhmx 0.0) + (ga 0.0) (ha 0.0)) + (declare (type (double-float) as at au c fa fhmn fhmx ga ha)) + (setf fa (abs f)) + (setf ga (abs g)) + (setf ha (abs h)) + (setf fhmn (min fa ha)) + (setf fhmx (max fa ha)) + (cond + ((= fhmn zero) + (setf ssmin zero) + (cond + ((= fhmx zero) + (setf ssmax ga)) + (t + (setf ssmax + (* (max fhmx ga) + (f2cl-lib:fsqrt + (+ one (expt (/ (min fhmx ga) (max fhmx ga)) 2)))))))) + (t + (cond + ((< ga fhmx) + (setf as (+ one (/ fhmn fhmx))) + (setf at (/ (- fhmx fhmn) fhmx)) + (setf au (expt (/ ga fhmx) 2)) + (setf c + (/ two + (+ (f2cl-lib:fsqrt (+ (* as as) au)) + (f2cl-lib:fsqrt (+ (* at at) au))))) + (setf ssmin (* fhmn c)) + (setf ssmax (/ fhmx c))) + (t + (setf au (/ fhmx ga)) + (cond + ((= au zero) + (setf ssmin (/ (* fhmn fhmx) ga)) + (setf ssmax ga)) + (t + (setf as (+ one (/ fhmn fhmx))) + (setf at (/ (- fhmx fhmn) fhmx)) + (setf c + (/ one + (+ (f2cl-lib:fsqrt (+ one (expt (* as au) 2))) + (f2cl-lib:fsqrt (+ one (expt (* at au) 2)))))) + (setf ssmin (* fhmn c au)) + (setf ssmin (+ ssmin ssmin)) + (setf ssmax (/ ga (+ c c))))))))) + (return (values nil nil nil ssmin ssmax))))) + +(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::dlas2 fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((double-float) (double-float) (double-float) + (double-float) (double-float)) + :return-values '(nil nil nil fortran-to-lisp::ssmin + fortran-to-lisp::ssmax) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlascl LAPACK} +\pagehead{dlascl}{dlascl} +%\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 dlascl (type kl ku cfrom cto m n a lda info) + (declare (type (array double-float (*)) a) + (type (double-float) cto cfrom) + (type fixnum info lda n m ku kl) + (type (simple-array character (*)) type)) + (f2cl-lib:with-multi-array-data + ((type double-float type-%data% type-%offset%) + (a double-float a-%data% a-%offset%)) + (prog ((bignum 0.0) (cfrom1 0.0) (cfromc 0.0) (cto1 0.0) (ctoc 0.0) + (mul 0.0) (smlnum 0.0) (i 0) (itype 0) (j 0) (k1 0) (k2 0) (k3 0) + (k4 0) (done nil)) + (declare (type (double-float) bignum cfrom1 cfromc cto1 ctoc mul + smlnum) + (type fixnum i itype j k1 k2 k3 k4) + (type (member t nil) done)) + (setf info 0) + (cond + ((lsame type "G") + (setf itype 0)) + ((lsame type "L") + (setf itype 1)) + ((lsame type "U") + (setf itype 2)) + ((lsame type "H") + (setf itype 3)) + ((lsame type "B") + (setf itype 4)) + ((lsame type "Q") + (setf itype 5)) + ((lsame type "Z") + (setf itype 6)) + (t + (setf itype -1))) + (cond + ((= itype (f2cl-lib:int-sub 1)) + (setf info -1)) + ((= cfrom zero) + (setf info -4)) + ((< m 0) + (setf info -6)) + ((or (< n 0) (and (= itype 4) (/= n m)) (and (= itype 5) (/= n m))) + (setf info -7)) + ((and (<= itype 3) + (< lda + (max (the fixnum 1) (the fixnum m)))) + (setf info -9)) + ((>= itype 4) + (cond + ((or (< kl 0) + (> kl + (max + (the fixnum + (f2cl-lib:int-add m (f2cl-lib:int-sub 1))) + (the fixnum 0)))) + (setf info -2)) + ((or (< ku 0) + (> ku + (max + (the fixnum + (f2cl-lib:int-add n (f2cl-lib:int-sub 1))) + (the fixnum 0))) + (and (or (= itype 4) (= itype 5)) (/= kl ku))) + (setf info -3)) + ((or (and (= itype 4) (< lda (f2cl-lib:int-add kl 1))) + (and (= itype 5) (< lda (f2cl-lib:int-add ku 1))) + (and (= itype 6) + (< lda (f2cl-lib:int-add (f2cl-lib:int-mul 2 kl) ku 1)))) + (setf info -9))))) + (cond + ((/= info 0) + (xerbla "DLASCL" (f2cl-lib:int-sub info)) + (go end_label))) + (if (or (= n 0) (= m 0)) (go end_label)) + (setf smlnum (dlamch "S")) + (setf bignum (/ one smlnum)) + (setf cfromc cfrom) + (setf ctoc cto) + label10 + (setf cfrom1 (* cfromc smlnum)) + (setf cto1 (/ ctoc bignum)) + (cond + ((and (> (abs cfrom1) (abs ctoc)) (/= ctoc zero)) + (setf mul smlnum) + (setf done nil) + (setf cfromc cfrom1)) + ((> (abs cto1) (abs cfromc)) + (setf mul bignum) + (setf done nil) + (setf ctoc cto1)) + (t + (setf mul (/ ctoc cfromc)) + (setf done t))) + (cond + ((= itype 0) + (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 a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + mul))))))) + ((= itype 1) + (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 a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + mul))))))) + ((= itype 2) + (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 a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + mul))))))) + ((= itype 3) + (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 + (f2cl-lib:int-add j 1)) + (the fixnum 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%) + mul))))))) + ((= itype 4) + (setf k3 (f2cl-lib:int-add kl 1)) + (setf k4 (f2cl-lib:int-add n 1)) + (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 k3) + (the fixnum + (f2cl-lib:int-add k4 + (f2cl-lib:int-sub + j))))) + 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%) + mul))))))) + ((= itype 5) + (setf k1 (f2cl-lib:int-add ku 2)) + (setf k3 (f2cl-lib:int-add ku 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i + (max + (the fixnum + (f2cl-lib:int-add k1 (f2cl-lib:int-sub j))) + (the fixnum 1)) + (f2cl-lib:int-add i 1)) + ((> i k3) 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%) + mul))))))) + ((= itype 6) + (setf k1 (f2cl-lib:int-add kl ku 2)) + (setf k2 (f2cl-lib:int-add kl 1)) + (setf k3 (f2cl-lib:int-add (f2cl-lib:int-mul 2 kl) ku 1)) + (setf k4 (f2cl-lib:int-add kl ku 1 m)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i + (max + (the fixnum + (f2cl-lib:int-add k1 (f2cl-lib:int-sub j))) + (the fixnum k2)) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum k3) + (the fixnum + (f2cl-lib:int-add k4 + (f2cl-lib:int-sub + j))))) + 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%) + mul)))))))) + (if (not done) (go label10)) + 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::dlascl + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum fixnum + (double-float) (double-float) + fixnum 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::dlamch fortran-to-lisp::xerbla + fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasd0 LAPACK} +\pagehead{dlasd0}{dlasd0} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun dlasd0 (n sqre d e u ldu vt ldvt smlsiz iwork work info) + (declare (type (array fixnum (*)) iwork) + (type (array double-float (*)) work vt u e d) + (type fixnum info smlsiz ldvt ldu sqre n)) + (f2cl-lib:with-multi-array-data + ((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%) + (work double-float work-%data% work-%offset%) + (iwork fixnum iwork-%data% iwork-%offset%)) + (prog ((alpha 0.0) (beta 0.0) (i 0) (i1 0) (ic 0) (idxq 0) (idxqc 0) + (im1 0) (inode 0) (itemp 0) (iwk 0) (j 0) (lf 0) (ll 0) (lvl 0) + (m 0) (ncc 0) (nd 0) (ndb1 0) (ndiml 0) (ndimr 0) (nl 0) (nlf 0) + (nlp1 0) (nlvl 0) (nr 0) (nrf 0) (nrp1 0) (sqrei 0)) + (declare (type fixnum sqrei nrp1 nrf nr nlvl nlp1 nlf nl + ndimr ndiml ndb1 nd ncc m lvl ll lf j + iwk itemp inode im1 idxqc idxq ic i1 + i) + (type (double-float) beta alpha)) + (setf info 0) + (cond + ((< n 0) + (setf info -1)) + ((or (< sqre 0) (> sqre 1)) + (setf info -2))) + (setf m (f2cl-lib:int-add n sqre)) + (cond + ((< ldu n) + (setf info -6)) + ((< ldvt m) + (setf info -8)) + ((< smlsiz 3) + (setf info -9))) + (cond + ((/= info 0) + (xerbla "DLASD0" (f2cl-lib:int-sub info)) + (go end_label))) + (cond + ((<= n smlsiz) + (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" sqre n m n 0 d e vt ldvt u ldu u ldu work 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 end_label))) + (setf inode 1) + (setf ndiml (f2cl-lib:int-add inode n)) + (setf ndimr (f2cl-lib:int-add ndiml n)) + (setf idxq (f2cl-lib:int-add ndimr n)) + (setf iwk (f2cl-lib:int-add idxq n)) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6) + (dlasdt n nlvl nd + (f2cl-lib:array-slice iwork fixnum (inode) ((1 *))) + (f2cl-lib:array-slice iwork fixnum (ndiml) ((1 *))) + (f2cl-lib:array-slice iwork fixnum (ndimr) ((1 *))) + smlsiz) + (declare (ignore var-0 var-3 var-4 var-5 var-6)) + (setf nlvl var-1) + (setf nd var-2)) + (setf ndb1 (the fixnum (truncate (+ nd 1) 2))) + (setf ncc 0) + (f2cl-lib:fdo (i ndb1 (f2cl-lib:int-add i 1)) + ((> i nd) nil) + (tagbody + (setf i1 (f2cl-lib:int-sub i 1)) + (setf ic + (f2cl-lib:fref iwork-%data% + ((f2cl-lib:int-add inode i1)) + ((1 *)) + iwork-%offset%)) + (setf nl + (f2cl-lib:fref iwork-%data% + ((f2cl-lib:int-add ndiml i1)) + ((1 *)) + iwork-%offset%)) + (setf nlp1 (f2cl-lib:int-add nl 1)) + (setf nr + (f2cl-lib:fref iwork-%data% + ((f2cl-lib:int-add ndimr i1)) + ((1 *)) + iwork-%offset%)) + (setf nrp1 (f2cl-lib:int-add nr 1)) + (setf nlf (f2cl-lib:int-sub ic nl)) + (setf nrf (f2cl-lib:int-add ic 1)) + (setf sqrei 1) + (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" sqrei nl nlp1 nl ncc + (f2cl-lib:array-slice d double-float (nlf) ((1 *))) + (f2cl-lib:array-slice e double-float (nlf) ((1 *))) + (f2cl-lib:array-slice vt + double-float + (nlf nlf) + ((1 ldvt) (1 *))) + ldvt + (f2cl-lib:array-slice u double-float (nlf nlf) ((1 ldu) (1 *))) + ldu + (f2cl-lib:array-slice u double-float (nlf nlf) ((1 ldu) (1 *))) + ldu work 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)) + (cond + ((/= info 0) + (go end_label))) + (setf itemp (f2cl-lib:int-sub (f2cl-lib:int-add idxq nlf) 2)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j nl) nil) + (tagbody + (setf (f2cl-lib:fref iwork-%data% + ((f2cl-lib:int-add itemp j)) + ((1 *)) + iwork-%offset%) + j))) + (cond + ((= i nd) + (setf sqrei sqre)) + (t + (setf sqrei 1))) + (setf nrp1 (f2cl-lib:int-add nr sqrei)) + (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" sqrei nr nrp1 nr ncc + (f2cl-lib:array-slice d double-float (nrf) ((1 *))) + (f2cl-lib:array-slice e double-float (nrf) ((1 *))) + (f2cl-lib:array-slice vt + double-float + (nrf nrf) + ((1 ldvt) (1 *))) + ldvt + (f2cl-lib:array-slice u double-float (nrf nrf) ((1 ldu) (1 *))) + ldu + (f2cl-lib:array-slice u double-float (nrf nrf) ((1 ldu) (1 *))) + ldu work 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)) + (cond + ((/= info 0) + (go end_label))) + (setf itemp (f2cl-lib:int-add idxq ic)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j nr) nil) + (tagbody + (setf (f2cl-lib:fref iwork-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add itemp j) + 1)) + ((1 *)) + iwork-%offset%) + j))))) + (f2cl-lib:fdo (lvl nlvl (f2cl-lib:int-add lvl (f2cl-lib:int-sub 1))) + ((> lvl 1) nil) + (tagbody + (cond + ((= lvl 1) + (setf lf 1) + (setf ll 1)) + (t + (setf lf (expt 2 (f2cl-lib:int-sub lvl 1))) + (setf ll (f2cl-lib:int-sub (f2cl-lib:int-mul 2 lf) 1)))) + (f2cl-lib:fdo (i lf (f2cl-lib:int-add i 1)) + ((> i ll) nil) + (tagbody + (setf im1 (f2cl-lib:int-sub i 1)) + (setf ic + (f2cl-lib:fref iwork-%data% + ((f2cl-lib:int-add inode im1)) + ((1 *)) + iwork-%offset%)) + (setf nl + (f2cl-lib:fref iwork-%data% + ((f2cl-lib:int-add ndiml im1)) + ((1 *)) + iwork-%offset%)) + (setf nr + (f2cl-lib:fref iwork-%data% + ((f2cl-lib:int-add ndimr im1)) + ((1 *)) + iwork-%offset%)) + (setf nlf (f2cl-lib:int-sub ic nl)) + (cond + ((and (= sqre 0) (= i ll)) + (setf sqrei sqre)) + (t + (setf sqrei 1))) + (setf idxqc (f2cl-lib:int-sub (f2cl-lib:int-add idxq nlf) 1)) + (setf alpha (f2cl-lib:fref d-%data% (ic) ((1 *)) d-%offset%)) + (setf beta (f2cl-lib:fref e-%data% (ic) ((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 var-10 var-11 var-12 var-13) + (dlasd1 nl nr sqrei + (f2cl-lib:array-slice d double-float (nlf) ((1 *))) alpha + beta + (f2cl-lib:array-slice u + double-float + (nlf nlf) + ((1 ldu) (1 *))) + ldu + (f2cl-lib:array-slice vt + double-float + (nlf nlf) + ((1 ldvt) (1 *))) + ldvt + (f2cl-lib:array-slice iwork + fixnum + (idxqc) + ((1 *))) + (f2cl-lib:array-slice iwork fixnum (iwk) ((1 *))) + work info) + (declare (ignore var-0 var-1 var-2 var-3 var-6 var-7 var-8 + var-9 var-10 var-11 var-12)) + (setf alpha var-4) + (setf beta var-5) + (setf info var-13)) + (cond + ((/= info 0) + (go end_label))))))) + end_label + (return (values 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::dlasd0 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (array double-float (*)) (array double-float (*)) + (array double-float (*)) fixnum + (array double-float (*)) fixnum + fixnum + (array fixnum (*)) + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlasd1 fortran-to-lisp::dlasdt + fortran-to-lisp::dlasdq fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasd1 LAPACK} +\pagehead{dlasd1}{dlasd1} +%\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 dlasd1 (nl nr sqre d alpha beta u ldu vt ldvt idxq iwork work info) + (declare (type (array fixnum (*)) iwork idxq) + (type (double-float) beta alpha) + (type (array double-float (*)) work vt u d) + (type fixnum info ldvt ldu sqre nr nl)) + (f2cl-lib:with-multi-array-data + ((d double-float d-%data% d-%offset%) + (u double-float u-%data% u-%offset%) + (vt double-float vt-%data% vt-%offset%) + (work double-float work-%data% work-%offset%) + (idxq fixnum idxq-%data% idxq-%offset%) + (iwork fixnum iwork-%data% iwork-%offset%)) + (prog ((orgnrm 0.0) (coltyp 0) (i 0) (idx 0) (idxc 0) (idxp 0) (iq 0) + (isigma 0) (iu2 0) (ivt2 0) (iz 0) (k 0) (ldq 0) (ldu2 0) + (ldvt2 0) (m 0) (n 0) (n1 0) (n2 0)) + (declare (type (double-float) orgnrm) + (type fixnum coltyp i idx idxc idxp iq isigma iu2 + ivt2 iz k ldq ldu2 ldvt2 m n n1 n2)) + (setf info 0) + (cond + ((< nl 1) + (setf info -1)) + ((< nr 1) + (setf info -2)) + ((or (< sqre 0) (> sqre 1)) + (setf info -3))) + (cond + ((/= info 0) + (xerbla "DLASD1" (f2cl-lib:int-sub info)) + (go end_label))) + (setf n (f2cl-lib:int-add nl nr 1)) + (setf m (f2cl-lib:int-add n sqre)) + (setf ldu2 n) + (setf ldvt2 m) + (setf iz 1) + (setf isigma (f2cl-lib:int-add iz m)) + (setf iu2 (f2cl-lib:int-add isigma n)) + (setf ivt2 (f2cl-lib:int-add iu2 (f2cl-lib:int-mul ldu2 n))) + (setf iq (f2cl-lib:int-add ivt2 (f2cl-lib:int-mul ldvt2 m))) + (setf idx 1) + (setf idxc (f2cl-lib:int-add idx n)) + (setf coltyp (f2cl-lib:int-add idxc n)) + (setf idxp (f2cl-lib:int-add coltyp n)) + (setf orgnrm (max (abs alpha) (abs beta))) + (setf (f2cl-lib:fref d-%data% + ((f2cl-lib:int-add nl 1)) + ((1 *)) + d-%offset%) + zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (cond + ((> (abs (f2cl-lib:fref d (i) ((1 *)))) orgnrm) + (setf orgnrm + (abs (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%))))))) + (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 info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf info var-9)) + (setf alpha (/ alpha orgnrm)) + (setf beta (/ beta orgnrm)) + (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) + (dlasd2 nl nr sqre k d + (f2cl-lib:array-slice work double-float (iz) ((1 *))) alpha beta u + ldu vt ldvt + (f2cl-lib:array-slice work double-float (isigma) ((1 *))) + (f2cl-lib:array-slice work double-float (iu2) ((1 *))) ldu2 + (f2cl-lib:array-slice work double-float (ivt2) ((1 *))) ldvt2 + (f2cl-lib:array-slice iwork fixnum (idxp) ((1 *))) + (f2cl-lib:array-slice iwork fixnum (idx) ((1 *))) + (f2cl-lib:array-slice iwork fixnum (idxc) ((1 *))) idxq + (f2cl-lib:array-slice iwork fixnum (coltyp) ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 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)) + (setf k var-3) + (setf info var-22)) + (setf ldq k) + (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) + (dlasd3 nl nr sqre k d + (f2cl-lib:array-slice work double-float (iq) ((1 *))) ldq + (f2cl-lib:array-slice work double-float (isigma) ((1 *))) u ldu + (f2cl-lib:array-slice work double-float (iu2) ((1 *))) ldu2 vt + ldvt (f2cl-lib:array-slice work double-float (ivt2) ((1 *))) ldvt2 + (f2cl-lib:array-slice iwork fixnum (idxc) ((1 *))) + (f2cl-lib:array-slice iwork fixnum (coltyp) ((1 *))) + (f2cl-lib:array-slice work double-float (iz) ((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 + var-15 var-16 var-17 var-18)) + (setf info var-19)) + (cond + ((/= info 0) + (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 one orgnrm n 1 d n info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf info var-9)) + (setf n1 k) + (setf n2 (f2cl-lib:int-sub n k)) + (dlamrg n1 n2 d 1 -1 idxq) + end_label + (return + (values nil + nil + nil + nil + alpha + beta + 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::dlasd1 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + fixnum (array double-float (*)) + (double-float) (double-float) (array double-float (*)) + fixnum (array double-float (*)) + fixnum + (array fixnum (*)) + (array fixnum (*)) + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil fortran-to-lisp::alpha + fortran-to-lisp::beta nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlamrg fortran-to-lisp::dlasd3 + fortran-to-lisp::dlasd2 fortran-to-lisp::dlascl + fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasd2 LAPACK} +\pagehead{dlasd2}{dlasd2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0) (one 1.0) (two 2.0) (eight 8.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) + (type (double-float 8.0 8.0) eight)) + (defun dlasd2 + (nl nr sqre k d z alpha beta u ldu vt ldvt dsigma u2 ldu2 vt2 ldvt2 + idxp idx idxc idxq coltyp info) + (declare (type (array fixnum (*)) coltyp idxq idxc idx idxp) + (type (double-float) beta alpha) + (type (array double-float (*)) vt2 u2 dsigma vt u z d) + (type fixnum info ldvt2 ldu2 ldvt ldu k sqre nr nl)) + (f2cl-lib:with-multi-array-data + ((d double-float d-%data% d-%offset%) + (z double-float z-%data% z-%offset%) + (u double-float u-%data% u-%offset%) + (vt double-float vt-%data% vt-%offset%) + (dsigma double-float dsigma-%data% dsigma-%offset%) + (u2 double-float u2-%data% u2-%offset%) + (vt2 double-float vt2-%data% vt2-%offset%) + (idxp fixnum idxp-%data% idxp-%offset%) + (idx fixnum idx-%data% idx-%offset%) + (idxc fixnum idxc-%data% idxc-%offset%) + (idxq fixnum idxq-%data% idxq-%offset%) + (coltyp fixnum coltyp-%data% coltyp-%offset%)) + (prog ((c 0.0) (eps 0.0) (hlftol 0.0) (s 0.0) (tau 0.0) (tol 0.0) + (z1 0.0) (ct 0) (i 0) (idxi 0) (idxj 0) (idxjp 0) (j 0) (jp 0) + (jprev 0) (k2 0) (m 0) (n 0) (nlp1 0) (nlp2 0) + (ctot (make-array 4 :element-type 'fixnum)) + (psm (make-array 4 :element-type 'fixnum))) + (declare (type (double-float) c eps hlftol s tau tol z1) + (type fixnum ct i idxi idxj idxjp j jp jprev k2 m + n nlp1 nlp2) + (type (array fixnum (4)) ctot psm)) + (setf info 0) + (cond + ((< nl 1) + (setf info -1)) + ((< nr 1) + (setf info -2)) + ((and (/= sqre 1) (/= sqre 0)) + (setf info -3))) + (setf n (f2cl-lib:int-add nl nr 1)) + (setf m (f2cl-lib:int-add n sqre)) + (cond + ((< ldu n) + (setf info -10)) + ((< ldvt m) + (setf info -12)) + ((< ldu2 n) + (setf info -15)) + ((< ldvt2 m) + (setf info -17))) + (cond + ((/= info 0) + (xerbla "DLASD2" (f2cl-lib:int-sub info)) + (go end_label))) + (setf nlp1 (f2cl-lib:int-add nl 1)) + (setf nlp2 (f2cl-lib:int-add nl 2)) + (setf z1 + (* alpha + (f2cl-lib:fref vt-%data% + (nlp1 nlp1) + ((1 ldvt) (1 *)) + vt-%offset%))) + (setf (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) z1) + (f2cl-lib:fdo (i nl (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + z-%offset%) + (* alpha + (f2cl-lib:fref vt-%data% + (i nlp1) + ((1 ldvt) (1 *)) + vt-%offset%))) + (setf (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 idxq-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + idxq-%offset%) + (f2cl-lib:int-add + (f2cl-lib:fref idxq-%data% (i) ((1 *)) idxq-%offset%) + 1)))) + (f2cl-lib:fdo (i nlp2 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%) + (* beta + (f2cl-lib:fref vt-%data% + (i nlp2) + ((1 ldvt) (1 *)) + vt-%offset%))))) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i nlp1) nil) + (tagbody + (setf (f2cl-lib:fref coltyp-%data% (i) ((1 *)) coltyp-%offset%) 1))) + (f2cl-lib:fdo (i nlp2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref coltyp-%data% (i) ((1 *)) coltyp-%offset%) 2))) + (f2cl-lib:fdo (i nlp2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref idxq-%data% (i) ((1 *)) idxq-%offset%) + (f2cl-lib:int-add + (f2cl-lib:fref idxq-%data% (i) ((1 *)) idxq-%offset%) + nlp1)))) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref dsigma-%data% (i) ((1 *)) dsigma-%offset%) + (f2cl-lib:fref d-%data% + ((f2cl-lib:fref idxq (i) ((1 *)))) + ((1 *)) + d-%offset%)) + (setf (f2cl-lib:fref u2-%data% (i 1) ((1 ldu2) (1 *)) u2-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:fref idxq (i) ((1 *)))) + ((1 *)) + z-%offset%)) + (setf (f2cl-lib:fref idxc-%data% (i) ((1 *)) idxc-%offset%) + (f2cl-lib:fref coltyp-%data% + ((f2cl-lib:fref idxq (i) ((1 *)))) + ((1 *)) + coltyp-%offset%)))) + (dlamrg nl nr (f2cl-lib:array-slice dsigma double-float (2) ((1 *))) 1 + 1 (f2cl-lib:array-slice idx fixnum (2) ((1 *)))) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf idxi + (f2cl-lib:int-add 1 + (f2cl-lib:fref idx-%data% + (i) + ((1 *)) + idx-%offset%))) + (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + (f2cl-lib:fref dsigma-%data% + (idxi) + ((1 *)) + dsigma-%offset%)) + (setf (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%) + (f2cl-lib:fref u2-%data% + (idxi 1) + ((1 ldu2) (1 *)) + u2-%offset%)) + (setf (f2cl-lib:fref coltyp-%data% (i) ((1 *)) coltyp-%offset%) + (f2cl-lib:fref idxc-%data% (idxi) ((1 *)) idxc-%offset%)))) + (setf eps (dlamch "Epsilon")) + (setf tol (max (abs alpha) (abs beta))) + (setf tol + (* eight + eps + (max (abs (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%)) + tol))) + (setf k 1) + (setf k2 (f2cl-lib:int-add n 1)) + (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((<= (abs (f2cl-lib:fref z (j) ((1 *)))) tol) + (setf k2 (f2cl-lib:int-sub k2 1)) + (setf (f2cl-lib:fref idxp-%data% (k2) ((1 *)) idxp-%offset%) j) + (setf (f2cl-lib:fref coltyp-%data% (j) ((1 *)) coltyp-%offset%) + 4) + (if (= j n) (go label120))) + (t + (setf jprev j) + (go label90))))) + label90 + (setf j jprev) + label100 + (setf j (f2cl-lib:int-add j 1)) + (if (> j n) (go label110)) + (cond + ((<= (abs (f2cl-lib:fref z (j) ((1 *)))) tol) + (setf k2 (f2cl-lib:int-sub k2 1)) + (setf (f2cl-lib:fref idxp-%data% (k2) ((1 *)) idxp-%offset%) j) + (setf (f2cl-lib:fref coltyp-%data% (j) ((1 *)) coltyp-%offset%) 4)) + (t + (cond + ((<= + (abs + (+ (f2cl-lib:fref d (j) ((1 *))) + (- (f2cl-lib:fref d (jprev) ((1 *)))))) + tol) + (setf s (f2cl-lib:fref z-%data% (jprev) ((1 *)) z-%offset%)) + (setf c (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%)) + (setf tau (dlapy2 c s)) + (setf c (/ c tau)) + (setf s (/ (- s) tau)) + (setf (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) tau) + (setf (f2cl-lib:fref z-%data% (jprev) ((1 *)) z-%offset%) zero) + (setf idxjp + (f2cl-lib:fref idxq-%data% + ((f2cl-lib:int-add + (f2cl-lib:fref idx (jprev) ((1 *))) + 1)) + ((1 *)) + idxq-%offset%)) + (setf idxj + (f2cl-lib:fref idxq-%data% + ((f2cl-lib:int-add + (f2cl-lib:fref idx (j) ((1 *))) + 1)) + ((1 *)) + idxq-%offset%)) + (cond + ((<= idxjp nlp1) + (setf idxjp (f2cl-lib:int-sub idxjp 1)))) + (cond + ((<= idxj nlp1) + (setf idxj (f2cl-lib:int-sub idxj 1)))) + (drot n + (f2cl-lib:array-slice u double-float (1 idxjp) ((1 ldu) (1 *))) + 1 (f2cl-lib:array-slice u double-float (1 idxj) ((1 ldu) (1 *))) + 1 c s) + (drot m + (f2cl-lib:array-slice vt + double-float + (idxjp 1) + ((1 ldvt) (1 *))) + ldvt + (f2cl-lib:array-slice vt double-float (idxj 1) ((1 ldvt) (1 *))) + ldvt c s) + (cond + ((/= (f2cl-lib:fref coltyp (j) ((1 *))) + (f2cl-lib:fref coltyp (jprev) ((1 *)))) + (setf (f2cl-lib:fref coltyp-%data% + (j) + ((1 *)) + coltyp-%offset%) + 3))) + (setf (f2cl-lib:fref coltyp-%data% + (jprev) + ((1 *)) + coltyp-%offset%) + 4) + (setf k2 (f2cl-lib:int-sub k2 1)) + (setf (f2cl-lib:fref idxp-%data% (k2) ((1 *)) idxp-%offset%) + jprev) + (setf jprev j)) + (t + (setf k (f2cl-lib:int-add k 1)) + (setf (f2cl-lib:fref u2-%data% + (k 1) + ((1 ldu2) (1 *)) + u2-%offset%) + (f2cl-lib:fref z-%data% (jprev) ((1 *)) z-%offset%)) + (setf (f2cl-lib:fref dsigma-%data% (k) ((1 *)) dsigma-%offset%) + (f2cl-lib:fref d-%data% (jprev) ((1 *)) d-%offset%)) + (setf (f2cl-lib:fref idxp-%data% (k) ((1 *)) idxp-%offset%) jprev) + (setf jprev j))))) + (go label100) + label110 + (setf k (f2cl-lib:int-add k 1)) + (setf (f2cl-lib:fref u2-%data% (k 1) ((1 ldu2) (1 *)) u2-%offset%) + (f2cl-lib:fref z-%data% (jprev) ((1 *)) z-%offset%)) + (setf (f2cl-lib:fref dsigma-%data% (k) ((1 *)) dsigma-%offset%) + (f2cl-lib:fref d-%data% (jprev) ((1 *)) d-%offset%)) + (setf (f2cl-lib:fref idxp-%data% (k) ((1 *)) idxp-%offset%) jprev) + label120 + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j 4) nil) + (tagbody (setf (f2cl-lib:fref ctot (j) ((1 4))) 0))) + (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf ct (f2cl-lib:fref coltyp-%data% (j) ((1 *)) coltyp-%offset%)) + (setf (f2cl-lib:fref ctot (ct) ((1 4))) + (f2cl-lib:int-add (f2cl-lib:fref ctot (ct) ((1 4))) 1)))) + (setf (f2cl-lib:fref psm (1) ((1 4))) 2) + (setf (f2cl-lib:fref psm (2) ((1 4))) + (f2cl-lib:int-add 2 (f2cl-lib:fref ctot (1) ((1 4))))) + (setf (f2cl-lib:fref psm (3) ((1 4))) + (f2cl-lib:int-add (f2cl-lib:fref psm (2) ((1 4))) + (f2cl-lib:fref ctot (2) ((1 4))))) + (setf (f2cl-lib:fref psm (4) ((1 4))) + (f2cl-lib:int-add (f2cl-lib:fref psm (3) ((1 4))) + (f2cl-lib:fref ctot (3) ((1 4))))) + (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf jp (f2cl-lib:fref idxp-%data% (j) ((1 *)) idxp-%offset%)) + (setf ct + (f2cl-lib:fref coltyp-%data% (jp) ((1 *)) coltyp-%offset%)) + (setf (f2cl-lib:fref idxc-%data% + ((f2cl-lib:fref psm (ct) ((1 4)))) + ((1 *)) + idxc-%offset%) + j) + (setf (f2cl-lib:fref psm (ct) ((1 4))) + (f2cl-lib:int-add (f2cl-lib:fref psm (ct) ((1 4))) 1)))) + (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf jp (f2cl-lib:fref idxp-%data% (j) ((1 *)) idxp-%offset%)) + (setf (f2cl-lib:fref dsigma-%data% (j) ((1 *)) dsigma-%offset%) + (f2cl-lib:fref d-%data% (jp) ((1 *)) d-%offset%)) + (setf idxj + (f2cl-lib:fref idxq-%data% + ((f2cl-lib:int-add + (f2cl-lib:fref idx + ((f2cl-lib:fref idxp + ((f2cl-lib:fref + idxc + (j) + ((1 *)))) + ((1 *)))) + ((1 *))) + 1)) + ((1 *)) + idxq-%offset%)) + (cond + ((<= idxj nlp1) + (setf idxj (f2cl-lib:int-sub idxj 1)))) + (dcopy n + (f2cl-lib:array-slice u double-float (1 idxj) ((1 ldu) (1 *))) 1 + (f2cl-lib:array-slice u2 double-float (1 j) ((1 ldu2) (1 *))) 1) + (dcopy m + (f2cl-lib:array-slice vt double-float (idxj 1) ((1 ldvt) (1 *))) + ldvt + (f2cl-lib:array-slice vt2 double-float (j 1) ((1 ldvt2) (1 *))) + ldvt2))) + (setf (f2cl-lib:fref dsigma-%data% (1) ((1 *)) dsigma-%offset%) zero) + (setf hlftol (/ tol two)) + (if + (<= (abs (f2cl-lib:fref dsigma-%data% (2) ((1 *)) dsigma-%offset%)) + hlftol) + (setf (f2cl-lib:fref dsigma-%data% (2) ((1 *)) dsigma-%offset%) + hlftol)) + (cond + ((> m n) + (setf (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) + (dlapy2 z1 (f2cl-lib:fref z-%data% (m) ((1 *)) z-%offset%))) + (cond + ((<= (f2cl-lib:fref z (1) ((1 *))) tol) + (setf c one) + (setf s zero) + (setf (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) tol)) + (t + (setf c (/ z1 (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%))) + (setf s + (/ (f2cl-lib:fref z-%data% (m) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%)))))) + (t + (cond + ((<= (abs z1) tol) + (setf (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) tol)) + (t + (setf (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) z1))))) + (dcopy (f2cl-lib:int-sub k 1) + (f2cl-lib:array-slice u2 double-float (2 1) ((1 ldu2) (1 *))) 1 + (f2cl-lib:array-slice z double-float (2) ((1 *))) 1) + (dlaset "A" n 1 zero zero u2 ldu2) + (setf (f2cl-lib:fref u2-%data% (nlp1 1) ((1 ldu2) (1 *)) u2-%offset%) + one) + (cond + ((> m n) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i nlp1) nil) + (tagbody + (setf (f2cl-lib:fref vt-%data% + (m i) + ((1 ldvt) (1 *)) + vt-%offset%) + (* (- s) + (f2cl-lib:fref vt-%data% + (nlp1 i) + ((1 ldvt) (1 *)) + vt-%offset%))) + (setf (f2cl-lib:fref vt2-%data% + (1 i) + ((1 ldvt2) (1 *)) + vt2-%offset%) + (* c + (f2cl-lib:fref vt-%data% + (nlp1 i) + ((1 ldvt) (1 *)) + vt-%offset%))))) + (f2cl-lib:fdo (i nlp2 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref vt2-%data% + (1 i) + ((1 ldvt2) (1 *)) + vt2-%offset%) + (* s + (f2cl-lib:fref vt-%data% + (m i) + ((1 ldvt) (1 *)) + vt-%offset%))) + (setf (f2cl-lib:fref vt-%data% + (m i) + ((1 ldvt) (1 *)) + vt-%offset%) + (* c + (f2cl-lib:fref vt-%data% + (m i) + ((1 ldvt) (1 *)) + vt-%offset%)))))) + (t + (dcopy m + (f2cl-lib:array-slice vt double-float (nlp1 1) ((1 ldvt) (1 *))) + ldvt + (f2cl-lib:array-slice vt2 double-float (1 1) ((1 ldvt2) (1 *))) + ldvt2))) + (cond + ((> m n) + (dcopy m + (f2cl-lib:array-slice vt double-float (m 1) ((1 ldvt) (1 *))) ldvt + (f2cl-lib:array-slice vt2 double-float (m 1) ((1 ldvt2) (1 *))) + ldvt2))) + (cond + ((> n k) + (dcopy (f2cl-lib:int-sub n k) + (f2cl-lib:array-slice dsigma double-float ((+ k 1)) ((1 *))) 1 + (f2cl-lib:array-slice d double-float ((+ k 1)) ((1 *))) 1) + (dlacpy "A" n (f2cl-lib:int-sub n k) + (f2cl-lib:array-slice u2 + double-float + (1 (f2cl-lib:int-add k 1)) + ((1 ldu2) (1 *))) + ldu2 + (f2cl-lib:array-slice u + double-float + (1 (f2cl-lib:int-add k 1)) + ((1 ldu) (1 *))) + ldu) + (dlacpy "A" (f2cl-lib:int-sub n k) m + (f2cl-lib:array-slice vt2 + double-float + ((+ k 1) 1) + ((1 ldvt2) (1 *))) + ldvt2 + (f2cl-lib:array-slice vt double-float ((+ k 1) 1) ((1 ldvt) (1 *))) + ldvt))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j 4) nil) + (tagbody + (setf (f2cl-lib:fref coltyp-%data% (j) ((1 *)) coltyp-%offset%) + (f2cl-lib:fref ctot (j) ((1 4)))))) + end_label + (return + (values nil + nil + nil + k + nil + nil + nil + nil + 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::dlasd2 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + fixnum fixnum + (array double-float (*)) (array double-float (*)) + (double-float) (double-float) (array double-float (*)) + fixnum (array double-float (*)) + fixnum (array double-float (*)) + (array double-float (*)) fixnum + (array double-float (*)) fixnum + (array fixnum (*)) + (array fixnum (*)) + (array fixnum (*)) + (array fixnum (*)) + (array fixnum (*)) + fixnum) + :return-values '(nil nil nil fortran-to-lisp::k nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlacpy fortran-to-lisp::dlaset + fortran-to-lisp::dcopy fortran-to-lisp::drot + fortran-to-lisp::dlapy2 fortran-to-lisp::dlamch + fortran-to-lisp::dlamrg fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasd3 LAPACK} +\pagehead{dlasd3}{dlasd3} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0) (zero 0.0) (negone (- 1.0))) + (declare (type (double-float 1.0 1.0) one) + (type (double-float 0.0 0.0) zero) + (type (double-float) negone)) + (defun dlasd3 + (nl nr sqre k d q ldq dsigma u ldu u2 ldu2 vt ldvt vt2 ldvt2 idxc ctot + z info) + (declare (type (array fixnum (*)) ctot idxc) + (type (array double-float (*)) z vt2 vt u2 u dsigma q d) + (type fixnum info ldvt2 ldvt ldu2 ldu ldq k sqre nr + nl)) + (f2cl-lib:with-multi-array-data + ((d double-float d-%data% d-%offset%) + (q double-float q-%data% q-%offset%) + (dsigma double-float dsigma-%data% dsigma-%offset%) + (u double-float u-%data% u-%offset%) + (u2 double-float u2-%data% u2-%offset%) + (vt double-float vt-%data% vt-%offset%) + (vt2 double-float vt2-%data% vt2-%offset%) + (z double-float z-%data% z-%offset%) + (idxc fixnum idxc-%data% idxc-%offset%) + (ctot fixnum ctot-%data% ctot-%offset%)) + (prog ((rho 0.0) (temp 0.0) (ctemp 0) (i 0) (j 0) (jc 0) (ktemp 0) (m 0) + (n 0) (nlp1 0) (nlp2 0) (nrp1 0)) + (declare (type (double-float) rho temp) + (type fixnum ctemp i j jc ktemp m n nlp1 nlp2 + nrp1)) + (setf info 0) + (cond + ((< nl 1) + (setf info -1)) + ((< nr 1) + (setf info -2)) + ((and (/= sqre 1) (/= sqre 0)) + (setf info -3))) + (setf n (f2cl-lib:int-add nl nr 1)) + (setf m (f2cl-lib:int-add n sqre)) + (setf nlp1 (f2cl-lib:int-add nl 1)) + (setf nlp2 (f2cl-lib:int-add nl 2)) + (cond + ((or (< k 1) (> k n)) + (setf info -4)) + ((< ldq k) + (setf info -7)) + ((< ldu n) + (setf info -10)) + ((< ldu2 n) + (setf info -12)) + ((< ldvt m) + (setf info -14)) + ((< ldvt2 m) + (setf info -16))) + (cond + ((/= info 0) + (xerbla "DLASD3" (f2cl-lib:int-sub info)) + (go end_label))) + (cond + ((= k 1) + (setf (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%) + (abs (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%))) + (dcopy m + (f2cl-lib:array-slice vt2 double-float (1 1) ((1 ldvt2) (1 *))) + ldvt2 (f2cl-lib:array-slice vt double-float (1 1) ((1 ldvt) (1 *))) + ldvt) + (cond + ((> (f2cl-lib:fref z (1) ((1 *))) zero) + (dcopy n + (f2cl-lib:array-slice u2 double-float (1 1) ((1 ldu2) (1 *))) 1 + (f2cl-lib:array-slice u double-float (1 1) ((1 ldu) (1 *))) 1)) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref u-%data% + (i 1) + ((1 ldu) (1 *)) + u-%offset%) + (- + (f2cl-lib:fref u2-%data% + (i 1) + ((1 ldu2) (1 *)) + u2-%offset%))))))) + (go end_label))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i k) nil) + (tagbody + (setf (f2cl-lib:fref dsigma-%data% (i) ((1 *)) dsigma-%offset%) + (- + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 + (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%)) + (declare (ignore)) + (setf (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + var-0) + (setf (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + var-1) + ret-val) + (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%))))) + (dcopy k z 1 q 1) + (setf rho (dnrm2 k z 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 rho one k 1 z k info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf info var-9)) + (setf rho (* rho rho)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dlasd4 k j dsigma z + (f2cl-lib:array-slice u double-float (1 j) ((1 ldu) (1 *))) + rho (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) + (f2cl-lib:array-slice vt double-float (1 j) ((1 ldvt) (1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-7)) + (setf (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) var-6) + (setf info var-8)) + (cond + ((/= info 0) + (go end_label))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i k) nil) + (tagbody + (setf (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref u-%data% (i k) ((1 ldu) (1 *)) u-%offset%) + (f2cl-lib:fref vt-%data% + (i k) + ((1 ldvt) (1 *)) + vt-%offset%))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) nil) + (tagbody + (setf (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%) + (* (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%) + (/ + (/ + (* + (f2cl-lib:fref u-%data% + (i j) + ((1 ldu) (1 *)) + u-%offset%) + (f2cl-lib:fref vt-%data% + (i j) + ((1 ldvt) (1 *)) + vt-%offset%)) + (- + (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + (f2cl-lib:fref dsigma-%data% + (j) + ((1 *)) + dsigma-%offset%))) + (+ + (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + (f2cl-lib:fref dsigma-%data% + (j) + ((1 *)) + dsigma-%offset%))))))) + (f2cl-lib:fdo (j i (f2cl-lib:int-add j 1)) + ((> j (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) nil) + (tagbody + (setf (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%) + (* (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%) + (/ + (/ + (* + (f2cl-lib:fref u-%data% + (i j) + ((1 ldu) (1 *)) + u-%offset%) + (f2cl-lib:fref vt-%data% + (i j) + ((1 ldvt) (1 *)) + vt-%offset%)) + (- + (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + (f2cl-lib:fref dsigma-%data% + ((f2cl-lib:int-add j 1)) + ((1 *)) + dsigma-%offset%))) + (+ + (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + (f2cl-lib:fref dsigma-%data% + ((f2cl-lib:int-add j 1)) + ((1 *)) + dsigma-%offset%))))))) + (setf (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%) + (f2cl-lib:sign + (f2cl-lib:fsqrt + (abs (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%))) + (f2cl-lib:fref q-%data% + (i 1) + ((1 ldq) (1 *)) + q-%offset%))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i k) nil) + (tagbody + (setf (f2cl-lib:fref vt-%data% (1 i) ((1 ldvt) (1 *)) vt-%offset%) + (/ + (/ (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) + (f2cl-lib:fref u-%data% + (1 i) + ((1 ldu) (1 *)) + u-%offset%)) + (f2cl-lib:fref vt-%data% + (1 i) + ((1 ldvt) (1 *)) + vt-%offset%))) + (setf (f2cl-lib:fref u-%data% (1 i) ((1 ldu) (1 *)) u-%offset%) + negone) + (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (setf (f2cl-lib:fref vt-%data% + (j i) + ((1 ldvt) (1 *)) + vt-%offset%) + (/ + (/ (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + (f2cl-lib:fref u-%data% + (j i) + ((1 ldu) (1 *)) + u-%offset%)) + (f2cl-lib:fref vt-%data% + (j i) + ((1 ldvt) (1 *)) + vt-%offset%))) + (setf (f2cl-lib:fref u-%data% (j i) ((1 ldu) (1 *)) u-%offset%) + (* + (f2cl-lib:fref dsigma-%data% + (j) + ((1 *)) + dsigma-%offset%) + (f2cl-lib:fref vt-%data% + (j i) + ((1 ldvt) (1 *)) + vt-%offset%))))) + (setf temp + (dnrm2 k + (f2cl-lib:array-slice u + double-float + (1 i) + ((1 ldu) (1 *))) + 1)) + (setf (f2cl-lib:fref q-%data% (1 i) ((1 ldq) (1 *)) q-%offset%) + (/ + (f2cl-lib:fref u-%data% (1 i) ((1 ldu) (1 *)) u-%offset%) + temp)) + (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (setf jc (f2cl-lib:fref idxc-%data% (j) ((1 *)) idxc-%offset%)) + (setf (f2cl-lib:fref q-%data% (j i) ((1 ldq) (1 *)) q-%offset%) + (/ + (f2cl-lib:fref u-%data% + (jc i) + ((1 ldu) (1 *)) + u-%offset%) + temp)))))) + (cond + ((= k 2) + (dgemm "N" "N" n k k one u2 ldu2 q ldq zero u ldu) + (go label100))) + (cond + ((> (f2cl-lib:fref ctot (1) ((1 *))) 0) + (dgemm "N" "N" nl k + (f2cl-lib:fref ctot-%data% (1) ((1 *)) ctot-%offset%) one + (f2cl-lib:array-slice u2 double-float (1 2) ((1 ldu2) (1 *))) ldu2 + (f2cl-lib:array-slice q double-float (2 1) ((1 ldq) (1 *))) ldq + zero (f2cl-lib:array-slice u double-float (1 1) ((1 ldu) (1 *))) + ldu) + (cond + ((> (f2cl-lib:fref ctot (3) ((1 *))) 0) + (setf ktemp + (f2cl-lib:int-add 2 + (f2cl-lib:fref ctot-%data% + (1) + ((1 *)) + ctot-%offset%) + (f2cl-lib:fref ctot-%data% + (2) + ((1 *)) + ctot-%offset%))) + (dgemm "N" "N" nl k + (f2cl-lib:fref ctot-%data% (3) ((1 *)) ctot-%offset%) one + (f2cl-lib:array-slice u2 + double-float + (1 ktemp) + ((1 ldu2) (1 *))) + ldu2 + (f2cl-lib:array-slice q double-float (ktemp 1) ((1 ldq) (1 *))) + ldq one + (f2cl-lib:array-slice u double-float (1 1) ((1 ldu) (1 *))) + ldu)))) + ((> (f2cl-lib:fref ctot (3) ((1 *))) 0) + (setf ktemp + (f2cl-lib:int-add 2 + (f2cl-lib:fref ctot-%data% + (1) + ((1 *)) + ctot-%offset%) + (f2cl-lib:fref ctot-%data% + (2) + ((1 *)) + ctot-%offset%))) + (dgemm "N" "N" nl k + (f2cl-lib:fref ctot-%data% (3) ((1 *)) ctot-%offset%) one + (f2cl-lib:array-slice u2 double-float (1 ktemp) ((1 ldu2) (1 *))) + ldu2 + (f2cl-lib:array-slice q double-float (ktemp 1) ((1 ldq) (1 *))) ldq + zero (f2cl-lib:array-slice u double-float (1 1) ((1 ldu) (1 *))) + ldu)) + (t + (dlacpy "F" nl k u2 ldu2 u ldu))) + (dcopy k (f2cl-lib:array-slice q double-float (1 1) ((1 ldq) (1 *))) + ldq (f2cl-lib:array-slice u double-float (nlp1 1) ((1 ldu) (1 *))) + ldu) + (setf ktemp + (f2cl-lib:int-add 2 + (f2cl-lib:fref ctot-%data% + (1) + ((1 *)) + ctot-%offset%))) + (setf ctemp + (f2cl-lib:int-add + (f2cl-lib:fref ctot-%data% (2) ((1 *)) ctot-%offset%) + (f2cl-lib:fref ctot-%data% (3) ((1 *)) ctot-%offset%))) + (dgemm "N" "N" nr k ctemp one + (f2cl-lib:array-slice u2 double-float (nlp2 ktemp) ((1 ldu2) (1 *))) + ldu2 (f2cl-lib:array-slice q double-float (ktemp 1) ((1 ldq) (1 *))) + ldq zero + (f2cl-lib:array-slice u double-float (nlp2 1) ((1 ldu) (1 *))) ldu) + label100 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i k) nil) + (tagbody + (setf temp + (dnrm2 k + (f2cl-lib:array-slice vt + double-float + (1 i) + ((1 ldvt) (1 *))) + 1)) + (setf (f2cl-lib:fref q-%data% (i 1) ((1 ldq) (1 *)) q-%offset%) + (/ + (f2cl-lib:fref vt-%data% + (1 i) + ((1 ldvt) (1 *)) + vt-%offset%) + temp)) + (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (setf jc (f2cl-lib:fref idxc-%data% (j) ((1 *)) idxc-%offset%)) + (setf (f2cl-lib:fref q-%data% (i j) ((1 ldq) (1 *)) q-%offset%) + (/ + (f2cl-lib:fref vt-%data% + (jc i) + ((1 ldvt) (1 *)) + vt-%offset%) + temp)))))) + (cond + ((= k 2) + (dgemm "N" "N" k m k one q ldq vt2 ldvt2 zero vt ldvt) + (go end_label))) + (setf ktemp + (f2cl-lib:int-add 1 + (f2cl-lib:fref ctot-%data% + (1) + ((1 *)) + ctot-%offset%))) + (dgemm "N" "N" k nlp1 ktemp one + (f2cl-lib:array-slice q double-float (1 1) ((1 ldq) (1 *))) ldq + (f2cl-lib:array-slice vt2 double-float (1 1) ((1 ldvt2) (1 *))) ldvt2 + zero (f2cl-lib:array-slice vt double-float (1 1) ((1 ldvt) (1 *))) + ldvt) + (setf ktemp + (f2cl-lib:int-add 2 + (f2cl-lib:fref ctot-%data% + (1) + ((1 *)) + ctot-%offset%) + (f2cl-lib:fref ctot-%data% + (2) + ((1 *)) + ctot-%offset%))) + (if (<= ktemp ldvt2) + (dgemm "N" "N" k nlp1 + (f2cl-lib:fref ctot-%data% (3) ((1 *)) ctot-%offset%) one + (f2cl-lib:array-slice q double-float (1 ktemp) ((1 ldq) (1 *))) + ldq + (f2cl-lib:array-slice vt2 + double-float + (ktemp 1) + ((1 ldvt2) (1 *))) + ldvt2 one + (f2cl-lib:array-slice vt double-float (1 1) ((1 ldvt) (1 *))) + ldvt)) + (setf ktemp + (f2cl-lib:int-add + (f2cl-lib:fref ctot-%data% (1) ((1 *)) ctot-%offset%) + 1)) + (setf nrp1 (f2cl-lib:int-add nr sqre)) + (cond + ((> ktemp 1) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i k) nil) + (tagbody + (setf (f2cl-lib:fref q-%data% + (i ktemp) + ((1 ldq) (1 *)) + q-%offset%) + (f2cl-lib:fref q-%data% + (i 1) + ((1 ldq) (1 *)) + q-%offset%)))) + (f2cl-lib:fdo (i nlp2 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref vt2-%data% + (ktemp i) + ((1 ldvt2) (1 *)) + vt2-%offset%) + (f2cl-lib:fref vt2-%data% + (1 i) + ((1 ldvt2) (1 *)) + vt2-%offset%)))))) + (setf ctemp + (f2cl-lib:int-add 1 + (f2cl-lib:fref ctot-%data% + (2) + ((1 *)) + ctot-%offset%) + (f2cl-lib:fref ctot-%data% + (3) + ((1 *)) + ctot-%offset%))) + (dgemm "N" "N" k nrp1 ctemp one + (f2cl-lib:array-slice q double-float (1 ktemp) ((1 ldq) (1 *))) ldq + (f2cl-lib:array-slice vt2 double-float (ktemp nlp2) ((1 ldvt2) (1 *))) + ldvt2 zero + (f2cl-lib:array-slice vt double-float (1 nlp2) ((1 ldvt) (1 *))) ldvt) + end_label + (return + (values nil + nil + nil + nil + nil + 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::dlasd3 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + fixnum fixnum + (array double-float (*)) (array double-float (*)) + fixnum (array double-float (*)) + (array double-float (*)) fixnum + (array double-float (*)) fixnum + (array double-float (*)) fixnum + (array double-float (*)) fixnum + (array fixnum (*)) + (array fixnum (*)) + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlacpy fortran-to-lisp::dgemm + fortran-to-lisp::dlasd4 fortran-to-lisp::dlascl + fortran-to-lisp::dnrm2 fortran-to-lisp::dlamc3 + fortran-to-lisp::dcopy fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasd4 LAPACK} +\pagehead{dlasd4}{dlasd4} +%\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) + (ten 10.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) + (type (double-float 10.0 10.0) ten)) + (defun dlasd4 (n i d z delta rho sigma work info) + (declare (type (double-float) sigma rho) + (type (array double-float (*)) work delta z d) + (type fixnum info i n)) + (f2cl-lib:with-multi-array-data + ((d double-float d-%data% d-%offset%) + (z double-float z-%data% z-%offset%) + (delta double-float delta-%data% delta-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((dd (make-array 3 :element-type 'double-float)) + (zz (make-array 3 :element-type 'double-float)) (a 0.0) (b 0.0) + (c 0.0) (delsq 0.0) (delsq2 0.0) (dphi 0.0) (dpsi 0.0) (dtiim 0.0) + (dtiip 0.0) (dtipsq 0.0) (dtisq 0.0) (dtnsq 0.0) (dtnsq1 0.0) + (dw 0.0) (eps 0.0) (erretm 0.0) (eta 0.0) (phi 0.0) (prew 0.0) + (psi 0.0) (rhoinv 0.0) (sg2lb 0.0) (sg2ub 0.0) (tau 0.0) + (temp 0.0) (temp1 0.0) (temp2 0.0) (w 0.0) (ii 0) (iim1 0) + (iip1 0) (ip1 0) (iter 0) (j 0) (niter 0) (orgati nil) (swtch nil) + (swtch3 nil)) + (declare (type (array double-float (3)) dd zz) + (type (double-float) a b c delsq delsq2 dphi dpsi dtiim dtiip + dtipsq dtisq dtnsq dtnsq1 dw eps erretm + eta phi prew psi rhoinv sg2lb sg2ub tau + temp temp1 temp2 w) + (type fixnum ii iim1 iip1 ip1 iter j niter) + (type (member t nil) orgati swtch swtch3)) + (setf info 0) + (cond + ((= n 1) + (setf sigma + (f2cl-lib:fsqrt + (+ + (* (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%)) + (* rho + (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%))))) + (setf (f2cl-lib:fref delta-%data% (1) ((1 *)) delta-%offset%) one) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) one) + (go end_label))) + (cond + ((= n 2) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6) + (dlasd5 i d z delta rho sigma work) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-6)) + (setf sigma var-5)) + (go end_label))) + (setf eps (dlamch "Epsilon")) + (setf rhoinv (/ one rho)) + (cond + ((= i n) + (setf ii (f2cl-lib:int-sub n 1)) + (setf niter 1) + (setf temp (/ rho two)) + (setf temp1 + (/ temp + (+ (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%) + (f2cl-lib:fsqrt + (+ + (* (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%)) + temp))))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (j) ((1 *)) work-%offset%) + (+ (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%) + temp1)) + (setf (f2cl-lib:fref delta-%data% (j) ((1 *)) delta-%offset%) + (- (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%) + temp1)))) + (setf psi zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j (f2cl-lib:int-add n (f2cl-lib:int-sub 2))) nil) + (tagbody + (setf psi + (+ psi + (/ + (* (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%)) + (* + (f2cl-lib:fref delta-%data% + (j) + ((1 *)) + delta-%offset%) + (f2cl-lib:fref work-%data% + (j) + ((1 *)) + work-%offset%))))))) + (setf c (+ rhoinv psi)) + (setf w + (+ c + (/ + (* (f2cl-lib:fref z-%data% (ii) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (ii) ((1 *)) z-%offset%)) + (* + (f2cl-lib:fref delta-%data% + (ii) + ((1 *)) + delta-%offset%) + (f2cl-lib:fref work-%data% + (ii) + ((1 *)) + work-%offset%))) + (/ + (* (f2cl-lib:fref z-%data% (n) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (n) ((1 *)) z-%offset%)) + (* + (f2cl-lib:fref delta-%data% (n) ((1 *)) delta-%offset%) + (f2cl-lib:fref work-%data% + (n) + ((1 *)) + work-%offset%))))) + (cond + ((<= w zero) + (setf temp1 + (f2cl-lib:fsqrt + (+ + (* (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%)) + rho))) + (setf temp + (+ + (/ + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub n 1)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub n 1)) + ((1 *)) + z-%offset%)) + (* + (+ + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub n 1)) + ((1 *)) + d-%offset%) + temp1) + (+ + (- (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub n 1)) + ((1 *)) + d-%offset%)) + (/ rho + (+ (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%) + temp1))))) + (/ + (* (f2cl-lib:fref z-%data% (n) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (n) ((1 *)) z-%offset%)) + rho))) + (cond + ((<= c temp) + (setf tau rho)) + (t + (setf delsq + (* + (- (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub n 1)) + ((1 *)) + d-%offset%)) + (+ (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub n 1)) + ((1 *)) + d-%offset%)))) + (setf a + (+ (* (- c) delsq) + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub n 1)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub n 1)) + ((1 *)) + z-%offset%)) + (* (f2cl-lib:fref z-%data% (n) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% + (n) + ((1 *)) + z-%offset%)))) + (setf b + (* (f2cl-lib:fref z-%data% (n) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (n) ((1 *)) z-%offset%) + delsq)) + (cond + ((< a zero) + (setf tau + (/ (* two b) + (- (f2cl-lib:fsqrt (+ (* a a) (* four b c))) + a)))) + (t + (setf tau + (/ (+ a (f2cl-lib:fsqrt (+ (* a a) (* four b c)))) + (* two c)))))))) + (t + (setf delsq + (* + (- (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub n 1)) + ((1 *)) + d-%offset%)) + (+ (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub n 1)) + ((1 *)) + d-%offset%)))) + (setf a + (+ (* (- c) delsq) + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub n 1)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub n 1)) + ((1 *)) + z-%offset%)) + (* (f2cl-lib:fref z-%data% (n) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (n) ((1 *)) z-%offset%)))) + (setf b + (* (f2cl-lib:fref z-%data% (n) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (n) ((1 *)) z-%offset%) + delsq)) + (cond + ((< a zero) + (setf tau + (/ (* two b) + (- (f2cl-lib:fsqrt (+ (* a a) (* four b c))) a)))) + (t + (setf tau + (/ (+ a (f2cl-lib:fsqrt (+ (* a a) (* four b c)))) + (* two c))))))) + (setf eta + (/ tau + (+ (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%) + (f2cl-lib:fsqrt + (+ + (* (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%)) + tau))))) + (setf sigma (+ (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%) eta)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf (f2cl-lib:fref delta-%data% (j) ((1 *)) delta-%offset%) + (- (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + eta)) + (setf (f2cl-lib:fref work-%data% (j) ((1 *)) work-%offset%) + (+ (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + eta)))) + (setf dpsi zero) + (setf psi zero) + (setf erretm zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j ii) nil) + (tagbody + (setf temp + (/ (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref delta-%data% + (j) + ((1 *)) + delta-%offset%) + (f2cl-lib:fref work-%data% + (j) + ((1 *)) + work-%offset%)))) + (setf psi + (+ psi + (* (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + temp))) + (setf dpsi (+ dpsi (* temp temp))) + (setf erretm (+ erretm psi)))) + (setf erretm (abs erretm)) + (setf temp + (/ (f2cl-lib:fref z-%data% (n) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref delta-%data% (n) ((1 *)) delta-%offset%) + (f2cl-lib:fref work-%data% (n) ((1 *)) work-%offset%)))) + (setf phi (* (f2cl-lib:fref z-%data% (n) ((1 *)) z-%offset%) temp)) + (setf dphi (* temp temp)) + (setf erretm + (+ (- (+ (* eight (- (- psi) phi)) erretm) phi) + rhoinv + (* (abs tau) (+ dpsi dphi)))) + (setf w (+ rhoinv phi psi)) + (cond + ((<= (abs w) (* eps erretm)) + (go end_label))) + (setf niter (f2cl-lib:int-add niter 1)) + (setf dtnsq1 + (* + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-sub n 1)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + ((f2cl-lib:int-sub n 1)) + ((1 *)) + delta-%offset%))) + (setf dtnsq + (* (f2cl-lib:fref work-%data% (n) ((1 *)) work-%offset%) + (f2cl-lib:fref delta-%data% (n) ((1 *)) delta-%offset%))) + (setf c (- w (* dtnsq1 dpsi) (* dtnsq dphi))) + (setf a + (+ (* (+ dtnsq dtnsq1) w) + (* (- dtnsq) dtnsq1 (+ dpsi dphi)))) + (setf b (* dtnsq dtnsq1 w)) + (if (< c zero) (setf c (abs c))) + (cond + ((= c zero) + (setf eta (- rho (* sigma sigma)))) + ((>= 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))))))))) + (if (> (* w eta) zero) (setf eta (/ (- w) (+ dpsi dphi)))) + (setf temp (- eta dtnsq)) + (if (> temp rho) (setf eta (+ rho dtnsq))) + (setf tau (+ tau eta)) + (setf eta (/ eta (+ sigma (f2cl-lib:fsqrt (+ eta (* sigma sigma)))))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf (f2cl-lib:fref delta-%data% (j) ((1 *)) delta-%offset%) + (- + (f2cl-lib:fref delta-%data% (j) ((1 *)) delta-%offset%) + eta)) + (setf (f2cl-lib:fref work-%data% (j) ((1 *)) work-%offset%) + (+ (f2cl-lib:fref work-%data% (j) ((1 *)) work-%offset%) + eta)))) + (setf sigma (+ sigma eta)) + (setf dpsi zero) + (setf psi zero) + (setf erretm zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j ii) nil) + (tagbody + (setf temp + (/ (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref work-%data% + (j) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + (j) + ((1 *)) + delta-%offset%)))) + (setf psi + (+ psi + (* (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + temp))) + (setf dpsi (+ dpsi (* temp temp))) + (setf erretm (+ erretm psi)))) + (setf erretm (abs erretm)) + (setf temp + (/ (f2cl-lib:fref z-%data% (n) ((1 *)) z-%offset%) + (* (f2cl-lib:fref work-%data% (n) ((1 *)) work-%offset%) + (f2cl-lib:fref delta-%data% + (n) + ((1 *)) + delta-%offset%)))) + (setf phi (* (f2cl-lib:fref z-%data% (n) ((1 *)) z-%offset%) temp)) + (setf dphi (* temp temp)) + (setf erretm + (+ (- (+ (* eight (- (- psi) phi)) erretm) phi) + rhoinv + (* (abs tau) (+ dpsi dphi)))) + (setf w (+ rhoinv phi psi)) + (setf iter (f2cl-lib:int-add niter 1)) + (f2cl-lib:fdo (niter iter (f2cl-lib:int-add niter 1)) + ((> niter maxit) nil) + (tagbody + (cond + ((<= (abs w) (* eps erretm)) + (go end_label))) + (setf dtnsq1 + (* + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-sub n 1)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + ((f2cl-lib:int-sub n 1)) + ((1 *)) + delta-%offset%))) + (setf dtnsq + (* (f2cl-lib:fref work-%data% (n) ((1 *)) work-%offset%) + (f2cl-lib:fref delta-%data% + (n) + ((1 *)) + delta-%offset%))) + (setf c (- w (* dtnsq1 dpsi) (* dtnsq dphi))) + (setf a + (+ (* (+ dtnsq dtnsq1) w) + (* (- dtnsq1) dtnsq (+ dpsi dphi)))) + (setf b (* dtnsq1 dtnsq w)) + (cond + ((>= 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))))))))) + (if (> (* w eta) zero) (setf eta (/ (- w) (+ dpsi dphi)))) + (setf temp (- eta dtnsq)) + (if (<= temp zero) (setf eta (/ eta two))) + (setf tau (+ tau eta)) + (setf eta + (/ eta + (+ sigma (f2cl-lib:fsqrt (+ eta (* sigma sigma)))))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf (f2cl-lib:fref delta-%data% + (j) + ((1 *)) + delta-%offset%) + (- + (f2cl-lib:fref delta-%data% + (j) + ((1 *)) + delta-%offset%) + eta)) + (setf (f2cl-lib:fref work-%data% (j) ((1 *)) work-%offset%) + (+ + (f2cl-lib:fref work-%data% + (j) + ((1 *)) + work-%offset%) + eta)))) + (setf sigma (+ sigma eta)) + (setf dpsi zero) + (setf psi zero) + (setf erretm zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j ii) nil) + (tagbody + (setf temp + (/ (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref work-%data% + (j) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + (j) + ((1 *)) + delta-%offset%)))) + (setf psi + (+ psi + (* + (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + temp))) + (setf dpsi (+ dpsi (* temp temp))) + (setf erretm (+ erretm psi)))) + (setf erretm (abs erretm)) + (setf temp + (/ (f2cl-lib:fref z-%data% (n) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref work-%data% + (n) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + (n) + ((1 *)) + delta-%offset%)))) + (setf phi + (* (f2cl-lib:fref z-%data% (n) ((1 *)) z-%offset%) + temp)) + (setf dphi (* temp temp)) + (setf erretm + (+ (- (+ (* eight (- (- psi) phi)) erretm) phi) + rhoinv + (* (abs tau) (+ dpsi dphi)))) + (setf w (+ rhoinv phi psi)))) + (setf info 1) + (go end_label)) + (t + (setf niter 1) + (setf ip1 (f2cl-lib:int-add i 1)) + (setf delsq + (* + (- (f2cl-lib:fref d-%data% (ip1) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) + (+ (f2cl-lib:fref d-%data% (ip1) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)))) + (setf delsq2 (/ delsq two)) + (setf temp + (/ delsq2 + (+ (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + (f2cl-lib:fsqrt + (+ + (* (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) + delsq2))))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (j) ((1 *)) work-%offset%) + (+ (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + temp)) + (setf (f2cl-lib:fref delta-%data% (j) ((1 *)) delta-%offset%) + (- (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + temp)))) + (setf psi zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) nil) + (tagbody + (setf psi + (+ psi + (/ + (* (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%)) + (* + (f2cl-lib:fref work-%data% + (j) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + (j) + ((1 *)) + delta-%offset%))))))) + (setf phi zero) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j (f2cl-lib:int-add i 2)) nil) + (tagbody + (setf phi + (+ phi + (/ + (* (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%)) + (* + (f2cl-lib:fref work-%data% + (j) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + (j) + ((1 *)) + delta-%offset%))))))) + (setf c (+ rhoinv psi phi)) + (setf w + (+ c + (/ + (* (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%)) + (* (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) + (f2cl-lib:fref delta-%data% + (i) + ((1 *)) + delta-%offset%))) + (/ + (* (f2cl-lib:fref z-%data% (ip1) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (ip1) ((1 *)) z-%offset%)) + (* + (f2cl-lib:fref work-%data% (ip1) ((1 *)) work-%offset%) + (f2cl-lib:fref delta-%data% + (ip1) + ((1 *)) + delta-%offset%))))) + (cond + ((> w zero) + (setf orgati t) + (setf sg2lb zero) + (setf sg2ub delsq2) + (setf a + (+ (* c delsq) + (* (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%)) + (* (f2cl-lib:fref z-%data% (ip1) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (ip1) ((1 *)) z-%offset%)))) + (setf b + (* (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%) + delsq)) + (cond + ((> a zero) + (setf tau + (/ (* two b) + (+ a + (f2cl-lib:fsqrt + (abs (+ (* a a) (* (- four) b c)))))))) + (t + (setf tau + (/ + (- a + (f2cl-lib:fsqrt + (abs (+ (* a a) (* (- four) b c))))) + (* two c))))) + (setf eta + (/ tau + (+ (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + (f2cl-lib:fsqrt + (+ + (* + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) + tau)))))) + (t + (setf orgati nil) + (setf sg2lb (- delsq2)) + (setf sg2ub zero) + (setf a + (- (* c delsq) + (* (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%)) + (* (f2cl-lib:fref z-%data% (ip1) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (ip1) ((1 *)) z-%offset%)))) + (setf b + (* (f2cl-lib:fref z-%data% (ip1) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (ip1) ((1 *)) z-%offset%) + delsq)) + (cond + ((< a zero) + (setf tau + (/ (* two b) + (- a + (f2cl-lib:fsqrt + (abs (+ (* a a) (* four b c)))))))) + (t + (setf tau + (/ + (- + (+ a + (f2cl-lib:fsqrt (abs (+ (* a a) (* four b c)))))) + (* two c))))) + (setf eta + (/ tau + (+ (f2cl-lib:fref d-%data% (ip1) ((1 *)) d-%offset%) + (f2cl-lib:fsqrt + (abs + (+ + (* + (f2cl-lib:fref d-%data% + (ip1) + ((1 *)) + d-%offset%) + (f2cl-lib:fref d-%data% + (ip1) + ((1 *)) + d-%offset%)) + tau)))))))) + (cond + (orgati + (setf ii i) + (setf sigma + (+ (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) eta)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (j) ((1 *)) work-%offset%) + (+ (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + eta)) + (setf (f2cl-lib:fref delta-%data% (j) ((1 *)) delta-%offset%) + (- (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + eta))))) + (t + (setf ii (f2cl-lib:int-add i 1)) + (setf sigma + (+ (f2cl-lib:fref d-%data% (ip1) ((1 *)) d-%offset%) eta)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (j) ((1 *)) work-%offset%) + (+ (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (ip1) ((1 *)) d-%offset%) + eta)) + (setf (f2cl-lib:fref delta-%data% (j) ((1 *)) delta-%offset%) + (- (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (ip1) ((1 *)) d-%offset%) + eta)))))) + (setf iim1 (f2cl-lib:int-sub ii 1)) + (setf iip1 (f2cl-lib:int-add ii 1)) + (setf dpsi zero) + (setf psi zero) + (setf erretm zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j iim1) nil) + (tagbody + (setf temp + (/ (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref work-%data% + (j) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + (j) + ((1 *)) + delta-%offset%)))) + (setf psi + (+ psi + (* (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + temp))) + (setf dpsi (+ dpsi (* temp temp))) + (setf erretm (+ erretm psi)))) + (setf erretm (abs erretm)) + (setf dphi zero) + (setf phi zero) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j iip1) nil) + (tagbody + (setf temp + (/ (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref work-%data% + (j) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + (j) + ((1 *)) + delta-%offset%)))) + (setf phi + (+ phi + (* (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + temp))) + (setf dphi (+ dphi (* temp temp))) + (setf erretm (+ erretm phi)))) + (setf w (+ rhoinv phi psi)) + (setf swtch3 nil) + (cond + (orgati + (if (< w zero) (setf swtch3 t))) + (t + (if (> w zero) (setf swtch3 t)))) + (if (or (= ii 1) (= ii n)) (setf swtch3 nil)) + (setf temp + (/ (f2cl-lib:fref z-%data% (ii) ((1 *)) z-%offset%) + (* (f2cl-lib:fref work-%data% (ii) ((1 *)) work-%offset%) + (f2cl-lib:fref delta-%data% + (ii) + ((1 *)) + delta-%offset%)))) + (setf dw (+ dpsi dphi (* temp temp))) + (setf temp (* (f2cl-lib:fref z-%data% (ii) ((1 *)) z-%offset%) temp)) + (setf w (+ w temp)) + (setf erretm + (+ (* eight (- phi psi)) + erretm + (* two rhoinv) + (* three (abs temp)) + (* (abs tau) dw))) + (cond + ((<= (abs w) (* eps erretm)) + (go end_label))) + (cond + ((<= w zero) + (setf sg2lb (max sg2lb tau))) + (t + (setf sg2ub (min sg2ub tau)))) + (setf niter (f2cl-lib:int-add niter 1)) + (cond + ((not swtch3) + (setf dtipsq + (* + (f2cl-lib:fref work-%data% (ip1) ((1 *)) work-%offset%) + (f2cl-lib:fref delta-%data% + (ip1) + ((1 *)) + delta-%offset%))) + (setf dtisq + (* (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) + (f2cl-lib:fref delta-%data% + (i) + ((1 *)) + delta-%offset%))) + (cond + (orgati + (setf c + (+ (- w (* dtipsq dw)) + (* delsq + (expt + (/ + (f2cl-lib:fref z-%data% + (i) + ((1 *)) + z-%offset%) + dtisq) + 2))))) + (t + (setf c + (- w + (* dtisq dw) + (* delsq + (expt + (/ + (f2cl-lib:fref z-%data% + (ip1) + ((1 *)) + z-%offset%) + dtipsq) + 2)))))) + (setf a (+ (* (+ dtipsq dtisq) w) (* (- dtipsq) dtisq dw))) + (setf b (* dtipsq dtisq w)) + (cond + ((= c zero) + (cond + ((= a zero) + (cond + (orgati + (setf a + (+ + (* + (f2cl-lib:fref z-%data% + (i) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + (i) + ((1 *)) + z-%offset%)) + (* dtipsq dtipsq (+ dpsi dphi))))) + (t + (setf a + (+ + (* + (f2cl-lib:fref z-%data% + (ip1) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + (ip1) + ((1 *)) + z-%offset%)) + (* dtisq dtisq (+ dpsi dphi)))))))) + (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)))))))))) + (t + (setf dtiim + (* + (f2cl-lib:fref work-%data% (iim1) ((1 *)) work-%offset%) + (f2cl-lib:fref delta-%data% + (iim1) + ((1 *)) + delta-%offset%))) + (setf dtiip + (* + (f2cl-lib:fref work-%data% (iip1) ((1 *)) work-%offset%) + (f2cl-lib:fref delta-%data% + (iip1) + ((1 *)) + delta-%offset%))) + (setf temp (+ rhoinv psi phi)) + (cond + (orgati + (setf temp1 + (/ (f2cl-lib:fref z-%data% (iim1) ((1 *)) z-%offset%) + dtiim)) + (setf temp1 (* temp1 temp1)) + (setf c + (+ (- temp (* dtiip (+ dpsi dphi))) + (* + (- + (- + (f2cl-lib:fref d-%data% + (iim1) + ((1 *)) + d-%offset%) + (f2cl-lib:fref d-%data% + (iip1) + ((1 *)) + d-%offset%))) + (+ + (f2cl-lib:fref d-%data% + (iim1) + ((1 *)) + d-%offset%) + (f2cl-lib:fref d-%data% + (iip1) + ((1 *)) + d-%offset%)) + temp1))) + (setf (f2cl-lib:fref zz (1) ((1 3))) + (* (f2cl-lib:fref z-%data% (iim1) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (iim1) ((1 *)) z-%offset%))) + (cond + ((< dpsi temp1) + (setf (f2cl-lib:fref zz (3) ((1 3))) (* dtiip dtiip dphi))) + (t + (setf (f2cl-lib:fref zz (3) ((1 3))) + (* dtiip dtiip (+ (- dpsi temp1) dphi)))))) + (t + (setf temp1 + (/ (f2cl-lib:fref z-%data% (iip1) ((1 *)) z-%offset%) + dtiip)) + (setf temp1 (* temp1 temp1)) + (setf c + (+ (- temp (* dtiim (+ dpsi dphi))) + (* + (- + (- + (f2cl-lib:fref d-%data% + (iip1) + ((1 *)) + d-%offset%) + (f2cl-lib:fref d-%data% + (iim1) + ((1 *)) + d-%offset%))) + (+ + (f2cl-lib:fref d-%data% + (iim1) + ((1 *)) + d-%offset%) + (f2cl-lib:fref d-%data% + (iip1) + ((1 *)) + d-%offset%)) + temp1))) + (cond + ((< dphi temp1) + (setf (f2cl-lib:fref zz (1) ((1 3))) (* dtiim dtiim dpsi))) + (t + (setf (f2cl-lib:fref zz (1) ((1 3))) + (* dtiim dtiim (+ dpsi (- dphi temp1)))))) + (setf (f2cl-lib:fref zz (3) ((1 3))) + (* (f2cl-lib:fref z-%data% (iip1) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% + (iip1) + ((1 *)) + z-%offset%))))) + (setf (f2cl-lib:fref zz (2) ((1 3))) + (* (f2cl-lib:fref z-%data% (ii) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (ii) ((1 *)) z-%offset%))) + (setf (f2cl-lib:fref dd (1) ((1 3))) dtiim) + (setf (f2cl-lib:fref dd (2) ((1 3))) + (* + (f2cl-lib:fref delta-%data% (ii) ((1 *)) delta-%offset%) + (f2cl-lib:fref work-%data% (ii) ((1 *)) work-%offset%))) + (setf (f2cl-lib:fref dd (3) ((1 3))) dtiip) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dlaed6 niter orgati c dd zz w eta info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5)) + (setf eta var-6) + (setf info var-7)) + (if (/= info 0) (go end_label)))) + (if (>= (* w eta) zero) (setf eta (/ (- w) dw))) + (cond + (orgati + (setf temp1 + (* (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) + (f2cl-lib:fref delta-%data% + (i) + ((1 *)) + delta-%offset%))) + (setf temp (- eta temp1))) + (t + (setf temp1 + (* + (f2cl-lib:fref work-%data% (ip1) ((1 *)) work-%offset%) + (f2cl-lib:fref delta-%data% + (ip1) + ((1 *)) + delta-%offset%))) + (setf temp (- eta temp1)))) + (cond + ((or (> temp sg2ub) (< temp sg2lb)) + (cond + ((< w zero) + (setf eta (/ (- sg2ub tau) two))) + (t + (setf eta (/ (- sg2lb tau) two)))))) + (setf tau (+ tau eta)) + (setf eta (/ eta (+ sigma (f2cl-lib:fsqrt (+ (* sigma sigma) eta))))) + (setf prew w) + (setf sigma (+ sigma eta)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (j) ((1 *)) work-%offset%) + (+ (f2cl-lib:fref work-%data% (j) ((1 *)) work-%offset%) + eta)) + (setf (f2cl-lib:fref delta-%data% (j) ((1 *)) delta-%offset%) + (- + (f2cl-lib:fref delta-%data% (j) ((1 *)) delta-%offset%) + eta)))) + (setf dpsi zero) + (setf psi zero) + (setf erretm zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j iim1) nil) + (tagbody + (setf temp + (/ (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref work-%data% + (j) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + (j) + ((1 *)) + delta-%offset%)))) + (setf psi + (+ psi + (* (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + temp))) + (setf dpsi (+ dpsi (* temp temp))) + (setf erretm (+ erretm psi)))) + (setf erretm (abs erretm)) + (setf dphi zero) + (setf phi zero) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j iip1) nil) + (tagbody + (setf temp + (/ (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref work-%data% + (j) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + (j) + ((1 *)) + delta-%offset%)))) + (setf phi + (+ phi + (* (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + temp))) + (setf dphi (+ dphi (* temp temp))) + (setf erretm (+ erretm phi)))) + (setf temp + (/ (f2cl-lib:fref z-%data% (ii) ((1 *)) z-%offset%) + (* (f2cl-lib:fref work-%data% (ii) ((1 *)) work-%offset%) + (f2cl-lib:fref delta-%data% + (ii) + ((1 *)) + delta-%offset%)))) + (setf dw (+ dpsi dphi (* temp temp))) + (setf temp (* (f2cl-lib:fref z-%data% (ii) ((1 *)) z-%offset%) temp)) + (setf w (+ rhoinv phi psi temp)) + (setf erretm + (+ (* eight (- phi psi)) + erretm + (* two rhoinv) + (* three (abs temp)) + (* (abs tau) dw))) + (cond + ((<= w zero) + (setf sg2lb (max sg2lb tau))) + (t + (setf sg2ub (min sg2ub tau)))) + (setf swtch nil) + (cond + (orgati + (if (> (- w) (/ (abs prew) ten)) (setf swtch t))) + (t + (if (> w (/ (abs prew) ten)) (setf swtch t)))) + (setf iter (f2cl-lib:int-add niter 1)) + (f2cl-lib:fdo (niter iter (f2cl-lib:int-add niter 1)) + ((> niter maxit) nil) + (tagbody + (cond + ((<= (abs w) (* eps erretm)) + (go end_label))) + (cond + ((not swtch3) + (setf dtipsq + (* + (f2cl-lib:fref work-%data% + (ip1) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + (ip1) + ((1 *)) + delta-%offset%))) + (setf dtisq + (* + (f2cl-lib:fref work-%data% + (i) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + (i) + ((1 *)) + delta-%offset%))) + (cond + ((not swtch) + (cond + (orgati + (setf c + (+ (- w (* dtipsq dw)) + (* delsq + (expt + (/ + (f2cl-lib:fref z-%data% + (i) + ((1 *)) + z-%offset%) + dtisq) + 2))))) + (t + (setf c + (- w + (* dtisq dw) + (* delsq + (expt + (/ + (f2cl-lib:fref z-%data% + (ip1) + ((1 *)) + z-%offset%) + dtipsq) + 2))))))) + (t + (setf temp + (/ + (f2cl-lib:fref z-%data% (ii) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref work-%data% + (ii) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + (ii) + ((1 *)) + delta-%offset%)))) + (cond + (orgati + (setf dpsi (+ dpsi (* temp temp)))) + (t + (setf dphi (+ dphi (* temp temp))))) + (setf c (- w (* dtisq dpsi) (* dtipsq dphi))))) + (setf a (+ (* (+ dtipsq dtisq) w) (* (- dtipsq) dtisq dw))) + (setf b (* dtipsq dtisq w)) + (cond + ((= c zero) + (cond + ((= a zero) + (cond + ((not swtch) + (cond + (orgati + (setf a + (+ + (* + (f2cl-lib:fref z-%data% + (i) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + (i) + ((1 *)) + z-%offset%)) + (* dtipsq dtipsq (+ dpsi dphi))))) + (t + (setf a + (+ + (* + (f2cl-lib:fref z-%data% + (ip1) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + (ip1) + ((1 *)) + z-%offset%)) + (* dtisq dtisq (+ dpsi dphi))))))) + (t + (setf a + (+ (* dtisq dtisq dpsi) + (* dtipsq dtipsq dphi))))))) + (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)))))))))) + (t + (setf dtiim + (* + (f2cl-lib:fref work-%data% + (iim1) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + (iim1) + ((1 *)) + delta-%offset%))) + (setf dtiip + (* + (f2cl-lib:fref work-%data% + (iip1) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + (iip1) + ((1 *)) + delta-%offset%))) + (setf temp (+ rhoinv psi phi)) + (cond + (swtch + (setf c (- temp (* dtiim dpsi) (* dtiip dphi))) + (setf (f2cl-lib:fref zz (1) ((1 3))) (* dtiim dtiim dpsi)) + (setf (f2cl-lib:fref zz (3) ((1 3))) (* dtiip dtiip dphi))) + (t + (cond + (orgati + (setf temp1 + (/ + (f2cl-lib:fref z-%data% + (iim1) + ((1 *)) + z-%offset%) + dtiim)) + (setf temp1 (* temp1 temp1)) + (setf temp2 + (* + (- + (f2cl-lib:fref d-%data% + (iim1) + ((1 *)) + d-%offset%) + (f2cl-lib:fref d-%data% + (iip1) + ((1 *)) + d-%offset%)) + (+ + (f2cl-lib:fref d-%data% + (iim1) + ((1 *)) + d-%offset%) + (f2cl-lib:fref d-%data% + (iip1) + ((1 *)) + d-%offset%)) + temp1)) + (setf c (- temp (* dtiip (+ dpsi dphi)) temp2)) + (setf (f2cl-lib:fref zz (1) ((1 3))) + (* + (f2cl-lib:fref z-%data% + (iim1) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + (iim1) + ((1 *)) + z-%offset%))) + (cond + ((< dpsi temp1) + (setf (f2cl-lib:fref zz (3) ((1 3))) + (* dtiip dtiip dphi))) + (t + (setf (f2cl-lib:fref zz (3) ((1 3))) + (* dtiip dtiip (+ (- dpsi temp1) dphi)))))) + (t + (setf temp1 + (/ + (f2cl-lib:fref z-%data% + (iip1) + ((1 *)) + z-%offset%) + dtiip)) + (setf temp1 (* temp1 temp1)) + (setf temp2 + (* + (- + (f2cl-lib:fref d-%data% + (iip1) + ((1 *)) + d-%offset%) + (f2cl-lib:fref d-%data% + (iim1) + ((1 *)) + d-%offset%)) + (+ + (f2cl-lib:fref d-%data% + (iim1) + ((1 *)) + d-%offset%) + (f2cl-lib:fref d-%data% + (iip1) + ((1 *)) + d-%offset%)) + temp1)) + (setf c (- temp (* dtiim (+ dpsi dphi)) temp2)) + (cond + ((< dphi temp1) + (setf (f2cl-lib:fref zz (1) ((1 3))) + (* dtiim dtiim dpsi))) + (t + (setf (f2cl-lib:fref zz (1) ((1 3))) + (* dtiim dtiim (+ dpsi (- dphi temp1)))))) + (setf (f2cl-lib:fref zz (3) ((1 3))) + (* + (f2cl-lib:fref z-%data% + (iip1) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + (iip1) + ((1 *)) + z-%offset%))))))) + (setf (f2cl-lib:fref dd (1) ((1 3))) dtiim) + (setf (f2cl-lib:fref dd (2) ((1 3))) + (* + (f2cl-lib:fref delta-%data% + (ii) + ((1 *)) + delta-%offset%) + (f2cl-lib:fref work-%data% + (ii) + ((1 *)) + work-%offset%))) + (setf (f2cl-lib:fref dd (3) ((1 3))) dtiip) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dlaed6 niter orgati c dd zz w eta info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5)) + (setf eta var-6) + (setf info var-7)) + (if (/= info 0) (go end_label)))) + (if (>= (* w eta) zero) (setf eta (/ (- w) dw))) + (cond + (orgati + (setf temp1 + (* + (f2cl-lib:fref work-%data% + (i) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + (i) + ((1 *)) + delta-%offset%))) + (setf temp (- eta temp1))) + (t + (setf temp1 + (* + (f2cl-lib:fref work-%data% + (ip1) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + (ip1) + ((1 *)) + delta-%offset%))) + (setf temp (- eta temp1)))) + (cond + ((or (> temp sg2ub) (< temp sg2lb)) + (cond + ((< w zero) + (setf eta (/ (- sg2ub tau) two))) + (t + (setf eta (/ (- sg2lb tau) two)))))) + (setf tau (+ tau eta)) + (setf eta + (/ eta + (+ sigma (f2cl-lib:fsqrt (+ (* sigma sigma) eta))))) + (setf sigma (+ sigma eta)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (j) ((1 *)) work-%offset%) + (+ + (f2cl-lib:fref work-%data% + (j) + ((1 *)) + work-%offset%) + eta)) + (setf (f2cl-lib:fref delta-%data% + (j) + ((1 *)) + delta-%offset%) + (- + (f2cl-lib:fref delta-%data% + (j) + ((1 *)) + delta-%offset%) + eta)))) + (setf prew w) + (setf dpsi zero) + (setf psi zero) + (setf erretm zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j iim1) nil) + (tagbody + (setf temp + (/ (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref work-%data% + (j) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + (j) + ((1 *)) + delta-%offset%)))) + (setf psi + (+ psi + (* + (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + temp))) + (setf dpsi (+ dpsi (* temp temp))) + (setf erretm (+ erretm psi)))) + (setf erretm (abs erretm)) + (setf dphi zero) + (setf phi zero) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j iip1) nil) + (tagbody + (setf temp + (/ (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref work-%data% + (j) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + (j) + ((1 *)) + delta-%offset%)))) + (setf phi + (+ phi + (* + (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) + temp))) + (setf dphi (+ dphi (* temp temp))) + (setf erretm (+ erretm phi)))) + (setf temp + (/ (f2cl-lib:fref z-%data% (ii) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref work-%data% + (ii) + ((1 *)) + work-%offset%) + (f2cl-lib:fref delta-%data% + (ii) + ((1 *)) + delta-%offset%)))) + (setf dw (+ dpsi dphi (* temp temp))) + (setf temp + (* (f2cl-lib:fref z-%data% (ii) ((1 *)) z-%offset%) + temp)) + (setf w (+ rhoinv phi psi temp)) + (setf erretm + (+ (* eight (- phi psi)) + erretm + (* two rhoinv) + (* three (abs temp)) + (* (abs tau) dw))) + (if (and (> (* w prew) zero) (> (abs w) (/ (abs prew) ten))) + (setf swtch (not swtch))) + (cond + ((<= w zero) + (setf sg2lb (max sg2lb tau))) + (t + (setf sg2ub (min sg2ub tau)))))) + (setf info 1))) + end_label + (return (values nil nil nil nil nil nil sigma 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::dlasd4 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (array double-float (*)) (array double-float (*)) + (array double-float (*)) (double-float) (double-float) + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil fortran-to-lisp::sigma nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlaed6 fortran-to-lisp::dlamch + fortran-to-lisp::dlasd5)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasd5 LAPACK} +\pagehead{dlasd5}{dlasd5} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0) (one 1.0) (two 2.0) (three 3.0) (four 4.0)) + (declare (type (double-float 0.0 0.0) zero) + (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)) + (defun dlasd5 (i d z delta rho dsigma work) + (declare (type (double-float) dsigma rho) + (type (array double-float (*)) work delta z d) + (type fixnum i)) + (f2cl-lib:with-multi-array-data + ((d double-float d-%data% d-%offset%) + (z double-float z-%data% z-%offset%) + (delta double-float delta-%data% delta-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((b 0.0) (c 0.0) (del 0.0) (delsq 0.0) (tau 0.0) (w 0.0)) + (declare (type (double-float) b c del delsq tau w)) + (setf del + (- (f2cl-lib:fref d-%data% (2) ((1 2)) d-%offset%) + (f2cl-lib:fref d-%data% (1) ((1 2)) d-%offset%))) + (setf delsq + (* del + (+ (f2cl-lib:fref d-%data% (2) ((1 2)) d-%offset%) + (f2cl-lib:fref d-%data% (1) ((1 2)) d-%offset%)))) + (cond + ((= i 1) + (setf w + (+ one + (/ + (* four + rho + (+ + (/ + (* (f2cl-lib:fref z-%data% (2) ((1 2)) z-%offset%) + (f2cl-lib:fref z-%data% (2) ((1 2)) z-%offset%)) + (+ (f2cl-lib:fref d-%data% (1) ((1 2)) d-%offset%) + (* three + (f2cl-lib:fref d-%data% + (2) + ((1 2)) + d-%offset%)))) + (/ + (* + (- + (f2cl-lib:fref z-%data% (1) ((1 2)) z-%offset%)) + (f2cl-lib:fref z-%data% (1) ((1 2)) z-%offset%)) + (+ + (* three + (f2cl-lib:fref d-%data% + (1) + ((1 2)) + d-%offset%)) + (f2cl-lib:fref d-%data% + (2) + ((1 2)) + d-%offset%))))) + del))) + (cond + ((> w zero) + (setf b + (+ delsq + (* rho + (+ + (* (f2cl-lib:fref z-%data% (1) ((1 2)) z-%offset%) + (f2cl-lib:fref z-%data% + (1) + ((1 2)) + z-%offset%)) + (* (f2cl-lib:fref z-%data% (2) ((1 2)) z-%offset%) + (f2cl-lib:fref z-%data% + (2) + ((1 2)) + z-%offset%)))))) + (setf c + (* rho + (f2cl-lib:fref z-%data% (1) ((1 2)) z-%offset%) + (f2cl-lib:fref z-%data% (1) ((1 2)) z-%offset%) + delsq)) + (setf tau + (/ (* two c) + (+ b (f2cl-lib:fsqrt (abs (- (* b b) (* four c))))))) + (setf tau + (/ tau + (+ (f2cl-lib:fref d-%data% (1) ((1 2)) d-%offset%) + (f2cl-lib:fsqrt + (+ + (* + (f2cl-lib:fref d-%data% (1) ((1 2)) d-%offset%) + (f2cl-lib:fref d-%data% (1) ((1 2)) d-%offset%)) + tau))))) + (setf dsigma + (+ (f2cl-lib:fref d-%data% (1) ((1 2)) d-%offset%) tau)) + (setf (f2cl-lib:fref delta-%data% (1) ((1 2)) delta-%offset%) + (- tau)) + (setf (f2cl-lib:fref delta-%data% (2) ((1 2)) delta-%offset%) + (- del tau)) + (setf (f2cl-lib:fref work-%data% (1) ((1 2)) work-%offset%) + (+ + (* two (f2cl-lib:fref d-%data% (1) ((1 2)) d-%offset%)) + tau)) + (setf (f2cl-lib:fref work-%data% (2) ((1 2)) work-%offset%) + (+ (f2cl-lib:fref d-%data% (1) ((1 2)) d-%offset%) + tau + (f2cl-lib:fref d-%data% (2) ((1 2)) d-%offset%)))) + (t + (setf b + (- + (* rho + (+ + (* (f2cl-lib:fref z-%data% (1) ((1 2)) z-%offset%) + (f2cl-lib:fref z-%data% (1) ((1 2)) z-%offset%)) + (* (f2cl-lib:fref z-%data% (2) ((1 2)) z-%offset%) + (f2cl-lib:fref z-%data% + (2) + ((1 2)) + z-%offset%)))) + delsq)) + (setf c + (* rho + (f2cl-lib:fref z-%data% (2) ((1 2)) z-%offset%) + (f2cl-lib:fref z-%data% (2) ((1 2)) z-%offset%) + delsq)) + (cond + ((> b zero) + (setf tau + (/ (* (- two) c) + (+ b (f2cl-lib:fsqrt (+ (* b b) (* four c))))))) + (t + (setf tau + (/ (- b (f2cl-lib:fsqrt (+ (* b b) (* four c)))) + two)))) + (setf tau + (/ tau + (+ (f2cl-lib:fref d-%data% (2) ((1 2)) d-%offset%) + (f2cl-lib:fsqrt + (abs + (+ + (* + (f2cl-lib:fref d-%data% (2) ((1 2)) d-%offset%) + (f2cl-lib:fref d-%data% + (2) + ((1 2)) + d-%offset%)) + tau)))))) + (setf dsigma + (+ (f2cl-lib:fref d-%data% (2) ((1 2)) d-%offset%) tau)) + (setf (f2cl-lib:fref delta-%data% (1) ((1 2)) delta-%offset%) + (- (+ del tau))) + (setf (f2cl-lib:fref delta-%data% (2) ((1 2)) delta-%offset%) + (- tau)) + (setf (f2cl-lib:fref work-%data% (1) ((1 2)) work-%offset%) + (+ (f2cl-lib:fref d-%data% (1) ((1 2)) d-%offset%) + tau + (f2cl-lib:fref d-%data% (2) ((1 2)) d-%offset%))) + (setf (f2cl-lib:fref work-%data% (2) ((1 2)) work-%offset%) + (+ + (* two (f2cl-lib:fref d-%data% (2) ((1 2)) d-%offset%)) + tau))))) + (t + (setf b + (- + (* rho + (+ + (* (f2cl-lib:fref z-%data% (1) ((1 2)) z-%offset%) + (f2cl-lib:fref z-%data% (1) ((1 2)) z-%offset%)) + (* (f2cl-lib:fref z-%data% (2) ((1 2)) z-%offset%) + (f2cl-lib:fref z-%data% (2) ((1 2)) z-%offset%)))) + delsq)) + (setf c + (* rho + (f2cl-lib:fref z-%data% (2) ((1 2)) z-%offset%) + (f2cl-lib:fref z-%data% (2) ((1 2)) z-%offset%) + delsq)) + (cond + ((> b zero) + (setf tau (/ (+ b (f2cl-lib:fsqrt (+ (* b b) (* four c)))) two))) + (t + (setf tau + (/ (* two c) + (- (f2cl-lib:fsqrt (+ (* b b) (* four c))) b))))) + (setf tau + (/ tau + (+ (f2cl-lib:fref d-%data% (2) ((1 2)) d-%offset%) + (f2cl-lib:fsqrt + (+ + (* (f2cl-lib:fref d-%data% (2) ((1 2)) d-%offset%) + (f2cl-lib:fref d-%data% (2) ((1 2)) d-%offset%)) + tau))))) + (setf dsigma (+ (f2cl-lib:fref d-%data% (2) ((1 2)) d-%offset%) tau)) + (setf (f2cl-lib:fref delta-%data% (1) ((1 2)) delta-%offset%) + (- (+ del tau))) + (setf (f2cl-lib:fref delta-%data% (2) ((1 2)) delta-%offset%) + (- tau)) + (setf (f2cl-lib:fref work-%data% (1) ((1 2)) work-%offset%) + (+ (f2cl-lib:fref d-%data% (1) ((1 2)) d-%offset%) + tau + (f2cl-lib:fref d-%data% (2) ((1 2)) d-%offset%))) + (setf (f2cl-lib:fref work-%data% (2) ((1 2)) work-%offset%) + (+ (* two (f2cl-lib:fref d-%data% (2) ((1 2)) d-%offset%)) + tau)))) + (return (values nil nil nil nil nil dsigma 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::dlasd5 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum (array double-float (2)) + (array double-float (2)) (array double-float (2)) + (double-float) (double-float) (array double-float (2))) + :return-values '(nil nil nil nil nil fortran-to-lisp::dsigma nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasd6 LAPACK} +\pagehead{dlasd6}{dlasd6} +%\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 dlasd6 + (icompq nl nr sqre d vf vl alpha beta idxq perm givptr givcol ldgcol + givnum ldgnum poles difl difr z k c s work iwork info) + (declare (type (array fixnum (*)) iwork givcol perm idxq) + (type (double-float) s c beta alpha) + (type (array double-float (*)) work z difr difl poles givnum vl vf + d) + (type fixnum info k ldgnum ldgcol givptr sqre nr nl + icompq)) + (f2cl-lib:with-multi-array-data + ((d double-float d-%data% d-%offset%) + (vf double-float vf-%data% vf-%offset%) + (vl double-float vl-%data% vl-%offset%) + (givnum double-float givnum-%data% givnum-%offset%) + (poles double-float poles-%data% poles-%offset%) + (difl double-float difl-%data% difl-%offset%) + (difr double-float difr-%data% difr-%offset%) + (z double-float z-%data% z-%offset%) + (work double-float work-%data% work-%offset%) + (idxq fixnum idxq-%data% idxq-%offset%) + (perm fixnum perm-%data% perm-%offset%) + (givcol fixnum givcol-%data% givcol-%offset%) + (iwork fixnum iwork-%data% iwork-%offset%)) + (prog ((orgnrm 0.0) (i 0) (idx 0) (idxc 0) (idxp 0) (isigma 0) (ivfw 0) + (ivlw 0) (iw 0) (m 0) (n 0) (n1 0) (n2 0)) + (declare (type (double-float) orgnrm) + (type fixnum i idx idxc idxp isigma ivfw ivlw iw + m n n1 n2)) + (setf info 0) + (setf n (f2cl-lib:int-add nl nr 1)) + (setf m (f2cl-lib:int-add n sqre)) + (cond + ((or (< icompq 0) (> icompq 1)) + (setf info -1)) + ((< nl 1) + (setf info -2)) + ((< nr 1) + (setf info -3)) + ((or (< sqre 0) (> sqre 1)) + (setf info -4)) + ((< ldgcol n) + (setf info -14)) + ((< ldgnum n) + (setf info -16))) + (cond + ((/= info 0) + (xerbla "DLASD6" (f2cl-lib:int-sub info)) + (go end_label))) + (setf isigma 1) + (setf iw (f2cl-lib:int-add isigma n)) + (setf ivfw (f2cl-lib:int-add iw m)) + (setf ivlw (f2cl-lib:int-add ivfw m)) + (setf idx 1) + (setf idxc (f2cl-lib:int-add idx n)) + (setf idxp (f2cl-lib:int-add idxc n)) + (setf orgnrm (max (abs alpha) (abs beta))) + (setf (f2cl-lib:fref d-%data% + ((f2cl-lib:int-add nl 1)) + ((1 *)) + d-%offset%) + zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (cond + ((> (abs (f2cl-lib:fref d (i) ((1 *)))) orgnrm) + (setf orgnrm + (abs (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%))))))) + (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 info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf info var-9)) + (setf alpha (/ alpha orgnrm)) + (setf beta (/ beta orgnrm)) + (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 var-24 var-25 var-26) + (dlasd7 icompq nl nr sqre k d z + (f2cl-lib:array-slice work double-float (iw) ((1 *))) vf + (f2cl-lib:array-slice work double-float (ivfw) ((1 *))) vl + (f2cl-lib:array-slice work double-float (ivlw) ((1 *))) alpha beta + (f2cl-lib:array-slice work double-float (isigma) ((1 *))) + (f2cl-lib:array-slice iwork fixnum (idx) ((1 *))) + (f2cl-lib:array-slice iwork fixnum (idxp) ((1 *))) idxq + perm givptr givcol ldgcol givnum ldgnum c s info) + (declare (ignore var-0 var-1 var-2 var-3 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-20 var-21 var-22 var-23)) + (setf k var-4) + (setf givptr var-19) + (setf c var-24) + (setf s var-25) + (setf info var-26)) + (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) + (dlasd8 icompq k d z vf vl difl difr ldgnum + (f2cl-lib:array-slice work double-float (isigma) ((1 *))) + (f2cl-lib:array-slice work double-float (iw) ((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)) + (cond + ((= icompq 1) + (dcopy k d 1 + (f2cl-lib:array-slice poles double-float (1 1) ((1 ldgnum) (1 *))) + 1) + (dcopy k (f2cl-lib:array-slice work double-float (isigma) ((1 *))) 1 + (f2cl-lib:array-slice poles double-float (1 2) ((1 ldgnum) (1 *))) + 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 info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf info var-9)) + (setf n1 k) + (setf n2 (f2cl-lib:int-sub n k)) + (dlamrg n1 n2 d 1 -1 idxq) + end_label + (return + (values nil + nil + nil + nil + nil + nil + nil + alpha + beta + nil + nil + givptr + nil + nil + nil + nil + nil + nil + nil + nil + k + c + s + 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::dlasd6 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + fixnum fixnum + (array double-float (*)) (array double-float (*)) + (array double-float (*)) (double-float) (double-float) + (array fixnum (*)) + (array fixnum (*)) + fixnum + (array fixnum (*)) + fixnum (array double-float (*)) + fixnum (array double-float (*)) + (array double-float (*)) (array double-float (*)) + (array double-float (*)) fixnum + (double-float) (double-float) (array double-float (*)) + (array fixnum (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::alpha + fortran-to-lisp::beta nil nil + fortran-to-lisp::givptr nil nil nil nil nil nil nil + nil fortran-to-lisp::k fortran-to-lisp::c + fortran-to-lisp::s nil nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlamrg fortran-to-lisp::dcopy + fortran-to-lisp::dlasd8 fortran-to-lisp::dlasd7 + fortran-to-lisp::dlascl fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasd7 LAPACK} +\pagehead{dlasd7}{dlasd7} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0) (one 1.0) (two 2.0) (eight 8.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) + (type (double-float 8.0 8.0) eight)) + (defun dlasd7 + (icompq nl nr sqre k d z zw vf vfw vl vlw alpha beta dsigma idx idxp + idxq perm givptr givcol ldgcol givnum ldgnum c s info) + (declare (type (array fixnum (*)) givcol perm idxq idxp idx) + (type (double-float) s c beta alpha) + (type (array double-float (*)) givnum dsigma vlw vl vfw vf zw z d) + (type fixnum info ldgnum ldgcol givptr k sqre nr nl + icompq)) + (f2cl-lib:with-multi-array-data + ((d double-float d-%data% d-%offset%) + (z double-float z-%data% z-%offset%) + (zw double-float zw-%data% zw-%offset%) + (vf double-float vf-%data% vf-%offset%) + (vfw double-float vfw-%data% vfw-%offset%) + (vl double-float vl-%data% vl-%offset%) + (vlw double-float vlw-%data% vlw-%offset%) + (dsigma double-float dsigma-%data% dsigma-%offset%) + (givnum double-float givnum-%data% givnum-%offset%) + (idx fixnum idx-%data% idx-%offset%) + (idxp fixnum idxp-%data% idxp-%offset%) + (idxq fixnum idxq-%data% idxq-%offset%) + (perm fixnum perm-%data% perm-%offset%) + (givcol fixnum givcol-%data% givcol-%offset%)) + (prog ((eps 0.0) (hlftol 0.0) (tau 0.0) (tol 0.0) (z1 0.0) (i 0) (idxi 0) + (idxj 0) (idxjp 0) (j 0) (jp 0) (jprev 0) (k2 0) (m 0) (n 0) + (nlp1 0) (nlp2 0)) + (declare (type (double-float) eps hlftol tau tol z1) + (type fixnum i idxi idxj idxjp j jp jprev k2 m n + nlp1 nlp2)) + (setf info 0) + (setf n (f2cl-lib:int-add nl nr 1)) + (setf m (f2cl-lib:int-add n sqre)) + (cond + ((or (< icompq 0) (> icompq 1)) + (setf info -1)) + ((< nl 1) + (setf info -2)) + ((< nr 1) + (setf info -3)) + ((or (< sqre 0) (> sqre 1)) + (setf info -4)) + ((< ldgcol n) + (setf info -22)) + ((< ldgnum n) + (setf info -24))) + (cond + ((/= info 0) + (xerbla "DLASD7" (f2cl-lib:int-sub info)) + (go end_label))) + (setf nlp1 (f2cl-lib:int-add nl 1)) + (setf nlp2 (f2cl-lib:int-add nl 2)) + (cond + ((= icompq 1) + (setf givptr 0))) + (setf z1 + (* alpha (f2cl-lib:fref vl-%data% (nlp1) ((1 *)) vl-%offset%))) + (setf (f2cl-lib:fref vl-%data% (nlp1) ((1 *)) vl-%offset%) zero) + (setf tau (f2cl-lib:fref vf-%data% (nlp1) ((1 *)) vf-%offset%)) + (f2cl-lib:fdo (i nl (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + z-%offset%) + (* alpha + (f2cl-lib:fref vl-%data% (i) ((1 *)) vl-%offset%))) + (setf (f2cl-lib:fref vl-%data% (i) ((1 *)) vl-%offset%) zero) + (setf (f2cl-lib:fref vf-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + vf-%offset%) + (f2cl-lib:fref vf-%data% (i) ((1 *)) vf-%offset%)) + (setf (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 idxq-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + idxq-%offset%) + (f2cl-lib:int-add + (f2cl-lib:fref idxq-%data% (i) ((1 *)) idxq-%offset%) + 1)))) + (setf (f2cl-lib:fref vf-%data% (1) ((1 *)) vf-%offset%) tau) + (f2cl-lib:fdo (i nlp2 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%) + (* beta (f2cl-lib:fref vf-%data% (i) ((1 *)) vf-%offset%))) + (setf (f2cl-lib:fref vf-%data% (i) ((1 *)) vf-%offset%) zero))) + (f2cl-lib:fdo (i nlp2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref idxq-%data% (i) ((1 *)) idxq-%offset%) + (f2cl-lib:int-add + (f2cl-lib:fref idxq-%data% (i) ((1 *)) idxq-%offset%) + nlp1)))) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref dsigma-%data% (i) ((1 *)) dsigma-%offset%) + (f2cl-lib:fref d-%data% + ((f2cl-lib:fref idxq (i) ((1 *)))) + ((1 *)) + d-%offset%)) + (setf (f2cl-lib:fref zw-%data% (i) ((1 *)) zw-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:fref idxq (i) ((1 *)))) + ((1 *)) + z-%offset%)) + (setf (f2cl-lib:fref vfw-%data% (i) ((1 *)) vfw-%offset%) + (f2cl-lib:fref vf-%data% + ((f2cl-lib:fref idxq (i) ((1 *)))) + ((1 *)) + vf-%offset%)) + (setf (f2cl-lib:fref vlw-%data% (i) ((1 *)) vlw-%offset%) + (f2cl-lib:fref vl-%data% + ((f2cl-lib:fref idxq (i) ((1 *)))) + ((1 *)) + vl-%offset%)))) + (dlamrg nl nr (f2cl-lib:array-slice dsigma double-float (2) ((1 *))) 1 + 1 (f2cl-lib:array-slice idx fixnum (2) ((1 *)))) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf idxi + (f2cl-lib:int-add 1 + (f2cl-lib:fref idx-%data% + (i) + ((1 *)) + idx-%offset%))) + (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + (f2cl-lib:fref dsigma-%data% + (idxi) + ((1 *)) + dsigma-%offset%)) + (setf (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%) + (f2cl-lib:fref zw-%data% (idxi) ((1 *)) zw-%offset%)) + (setf (f2cl-lib:fref vf-%data% (i) ((1 *)) vf-%offset%) + (f2cl-lib:fref vfw-%data% (idxi) ((1 *)) vfw-%offset%)) + (setf (f2cl-lib:fref vl-%data% (i) ((1 *)) vl-%offset%) + (f2cl-lib:fref vlw-%data% (idxi) ((1 *)) vlw-%offset%)))) + (setf eps (dlamch "Epsilon")) + (setf tol (max (abs alpha) (abs beta))) + (setf tol + (* eight + eight + eps + (max (abs (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%)) + tol))) + (setf k 1) + (setf k2 (f2cl-lib:int-add n 1)) + (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((<= (abs (f2cl-lib:fref z (j) ((1 *)))) tol) + (setf k2 (f2cl-lib:int-sub k2 1)) + (setf (f2cl-lib:fref idxp-%data% (k2) ((1 *)) idxp-%offset%) j) + (if (= j n) (go label100))) + (t + (setf jprev j) + (go label70))))) + label70 + (setf j jprev) + label80 + (setf j (f2cl-lib:int-add j 1)) + (if (> j n) (go label90)) + (cond + ((<= (abs (f2cl-lib:fref z (j) ((1 *)))) tol) + (setf k2 (f2cl-lib:int-sub k2 1)) + (setf (f2cl-lib:fref idxp-%data% (k2) ((1 *)) idxp-%offset%) j)) + (t + (cond + ((<= + (abs + (+ (f2cl-lib:fref d (j) ((1 *))) + (- (f2cl-lib:fref d (jprev) ((1 *)))))) + tol) + (setf s (f2cl-lib:fref z-%data% (jprev) ((1 *)) z-%offset%)) + (setf c (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%)) + (setf tau (dlapy2 c s)) + (setf (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%) tau) + (setf (f2cl-lib:fref z-%data% (jprev) ((1 *)) z-%offset%) zero) + (setf c (/ c tau)) + (setf s (/ (- s) tau)) + (cond + ((= icompq 1) + (setf givptr (f2cl-lib:int-add givptr 1)) + (setf idxjp + (f2cl-lib:fref idxq-%data% + ((f2cl-lib:int-add + (f2cl-lib:fref idx (jprev) ((1 *))) + 1)) + ((1 *)) + idxq-%offset%)) + (setf idxj + (f2cl-lib:fref idxq-%data% + ((f2cl-lib:int-add + (f2cl-lib:fref idx (j) ((1 *))) + 1)) + ((1 *)) + idxq-%offset%)) + (cond + ((<= idxjp nlp1) + (setf idxjp (f2cl-lib:int-sub idxjp 1)))) + (cond + ((<= idxj nlp1) + (setf idxj (f2cl-lib:int-sub idxj 1)))) + (setf (f2cl-lib:fref givcol-%data% + (givptr 2) + ((1 ldgcol) (1 *)) + givcol-%offset%) + idxjp) + (setf (f2cl-lib:fref givcol-%data% + (givptr 1) + ((1 ldgcol) (1 *)) + givcol-%offset%) + idxj) + (setf (f2cl-lib:fref givnum-%data% + (givptr 2) + ((1 ldgnum) (1 *)) + givnum-%offset%) + c) + (setf (f2cl-lib:fref givnum-%data% + (givptr 1) + ((1 ldgnum) (1 *)) + givnum-%offset%) + s))) + (drot 1 (f2cl-lib:array-slice vf double-float (jprev) ((1 *))) 1 + (f2cl-lib:array-slice vf double-float (j) ((1 *))) 1 c s) + (drot 1 (f2cl-lib:array-slice vl double-float (jprev) ((1 *))) 1 + (f2cl-lib:array-slice vl double-float (j) ((1 *))) 1 c s) + (setf k2 (f2cl-lib:int-sub k2 1)) + (setf (f2cl-lib:fref idxp-%data% (k2) ((1 *)) idxp-%offset%) + jprev) + (setf jprev j)) + (t + (setf k (f2cl-lib:int-add k 1)) + (setf (f2cl-lib:fref zw-%data% (k) ((1 *)) zw-%offset%) + (f2cl-lib:fref z-%data% (jprev) ((1 *)) z-%offset%)) + (setf (f2cl-lib:fref dsigma-%data% (k) ((1 *)) dsigma-%offset%) + (f2cl-lib:fref d-%data% (jprev) ((1 *)) d-%offset%)) + (setf (f2cl-lib:fref idxp-%data% (k) ((1 *)) idxp-%offset%) jprev) + (setf jprev j))))) + (go label80) + label90 + (setf k (f2cl-lib:int-add k 1)) + (setf (f2cl-lib:fref zw-%data% (k) ((1 *)) zw-%offset%) + (f2cl-lib:fref z-%data% (jprev) ((1 *)) z-%offset%)) + (setf (f2cl-lib:fref dsigma-%data% (k) ((1 *)) dsigma-%offset%) + (f2cl-lib:fref d-%data% (jprev) ((1 *)) d-%offset%)) + (setf (f2cl-lib:fref idxp-%data% (k) ((1 *)) idxp-%offset%) jprev) + label100 + (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf jp (f2cl-lib:fref idxp-%data% (j) ((1 *)) idxp-%offset%)) + (setf (f2cl-lib:fref dsigma-%data% (j) ((1 *)) dsigma-%offset%) + (f2cl-lib:fref d-%data% (jp) ((1 *)) d-%offset%)) + (setf (f2cl-lib:fref vfw-%data% (j) ((1 *)) vfw-%offset%) + (f2cl-lib:fref vf-%data% (jp) ((1 *)) vf-%offset%)) + (setf (f2cl-lib:fref vlw-%data% (j) ((1 *)) vlw-%offset%) + (f2cl-lib:fref vl-%data% (jp) ((1 *)) vl-%offset%)))) + (cond + ((= icompq 1) + (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf jp (f2cl-lib:fref idxp-%data% (j) ((1 *)) idxp-%offset%)) + (setf (f2cl-lib:fref perm-%data% (j) ((1 *)) perm-%offset%) + (f2cl-lib:fref idxq-%data% + ((f2cl-lib:int-add + (f2cl-lib:fref idx (jp) ((1 *))) + 1)) + ((1 *)) + idxq-%offset%)) + (cond + ((<= (f2cl-lib:fref perm (j) ((1 *))) nlp1) + (setf (f2cl-lib:fref perm-%data% (j) ((1 *)) perm-%offset%) + (f2cl-lib:int-sub + (f2cl-lib:fref perm-%data% + (j) + ((1 *)) + perm-%offset%) + 1)))))))) + (dcopy (f2cl-lib:int-sub n k) + (f2cl-lib:array-slice dsigma double-float ((+ k 1)) ((1 *))) 1 + (f2cl-lib:array-slice d double-float ((+ k 1)) ((1 *))) 1) + (setf (f2cl-lib:fref dsigma-%data% (1) ((1 *)) dsigma-%offset%) zero) + (setf hlftol (/ tol two)) + (if + (<= (abs (f2cl-lib:fref dsigma-%data% (2) ((1 *)) dsigma-%offset%)) + hlftol) + (setf (f2cl-lib:fref dsigma-%data% (2) ((1 *)) dsigma-%offset%) + hlftol)) + (cond + ((> m n) + (setf (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) + (dlapy2 z1 (f2cl-lib:fref z-%data% (m) ((1 *)) z-%offset%))) + (cond + ((<= (f2cl-lib:fref z (1) ((1 *))) tol) + (setf c one) + (setf s zero) + (setf (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) tol)) + (t + (setf c (/ z1 (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%))) + (setf s + (/ (- (f2cl-lib:fref z-%data% (m) ((1 *)) z-%offset%)) + (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%))))) + (drot 1 (f2cl-lib:array-slice vf double-float (m) ((1 *))) 1 + (f2cl-lib:array-slice vf double-float (1) ((1 *))) 1 c s) + (drot 1 (f2cl-lib:array-slice vl double-float (m) ((1 *))) 1 + (f2cl-lib:array-slice vl double-float (1) ((1 *))) 1 c s)) + (t + (cond + ((<= (abs z1) tol) + (setf (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) tol)) + (t + (setf (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) z1))))) + (dcopy (f2cl-lib:int-sub k 1) + (f2cl-lib:array-slice zw double-float (2) ((1 *))) 1 + (f2cl-lib:array-slice z double-float (2) ((1 *))) 1) + (dcopy (f2cl-lib:int-sub n 1) + (f2cl-lib:array-slice vfw double-float (2) ((1 *))) 1 + (f2cl-lib:array-slice vf double-float (2) ((1 *))) 1) + (dcopy (f2cl-lib:int-sub n 1) + (f2cl-lib:array-slice vlw double-float (2) ((1 *))) 1 + (f2cl-lib:array-slice vl double-float (2) ((1 *))) 1) + end_label + (return + (values nil + nil + nil + nil + k + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + givptr + nil + nil + nil + nil + c + s + 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::dlasd7 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + fixnum fixnum + fixnum (array double-float (*)) + (array double-float (*)) (array double-float (*)) + (array double-float (*)) (array double-float (*)) + (array double-float (*)) (array double-float (*)) + (double-float) (double-float) (array double-float (*)) + (array fixnum (*)) + (array fixnum (*)) + (array fixnum (*)) + (array fixnum (*)) + fixnum + (array fixnum (*)) + fixnum (array double-float (*)) + fixnum (double-float) + (double-float) fixnum) + :return-values '(nil nil nil nil fortran-to-lisp::k nil nil nil nil + nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::givptr nil nil nil nil + fortran-to-lisp::c fortran-to-lisp::s + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dcopy fortran-to-lisp::drot + fortran-to-lisp::dlapy2 fortran-to-lisp::dlamch + fortran-to-lisp::dlamrg fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasd8 LAPACK} +\pagehead{dlasd8}{dlasd8} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0)) + (declare (type (double-float 1.0 1.0) one)) + (defun dlasd8 (icompq k d z vf vl difl difr lddifr dsigma work info) + (declare (type (array double-float (*)) work dsigma difr difl vl vf z d) + (type fixnum info lddifr k icompq)) + (f2cl-lib:with-multi-array-data + ((d double-float d-%data% d-%offset%) + (z double-float z-%data% z-%offset%) + (vf double-float vf-%data% vf-%offset%) + (vl double-float vl-%data% vl-%offset%) + (difl double-float difl-%data% difl-%offset%) + (difr double-float difr-%data% difr-%offset%) + (dsigma double-float dsigma-%data% dsigma-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((diflj 0.0) (difrj 0.0) (dj 0.0) (dsigj 0.0) (dsigjp 0.0) + (rho 0.0) (temp 0.0) (i 0) (iwk1 0) (iwk2 0) (iwk2i 0) (iwk3 0) + (iwk3i 0) (j 0)) + (declare (type (double-float) diflj difrj dj dsigj dsigjp rho temp) + (type fixnum i iwk1 iwk2 iwk2i iwk3 iwk3i j)) + (setf info 0) + (cond + ((or (< icompq 0) (> icompq 1)) + (setf info -1)) + ((< k 1) + (setf info -2)) + ((< lddifr k) + (setf info -9))) + (cond + ((/= info 0) + (xerbla "DLASD8" (f2cl-lib:int-sub info)) + (go end_label))) + (cond + ((= k 1) + (setf (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%) + (abs (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%))) + (setf (f2cl-lib:fref difl-%data% (1) ((1 *)) difl-%offset%) + (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%)) + (cond + ((= icompq 1) + (setf (f2cl-lib:fref difl-%data% (2) ((1 *)) difl-%offset%) one) + (setf (f2cl-lib:fref difr-%data% + (1 2) + ((1 lddifr) (1 *)) + difr-%offset%) + one))) + (go end_label))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i k) nil) + (tagbody + (setf (f2cl-lib:fref dsigma-%data% (i) ((1 *)) dsigma-%offset%) + (- + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 + (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%)) + (declare (ignore)) + (setf (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + var-0) + (setf (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + var-1) + ret-val) + (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%))))) + (setf iwk1 1) + (setf iwk2 (f2cl-lib:int-add iwk1 k)) + (setf iwk3 (f2cl-lib:int-add iwk2 k)) + (setf iwk2i (f2cl-lib:int-sub iwk2 1)) + (setf iwk3i (f2cl-lib:int-sub iwk3 1)) + (setf rho (dnrm2 k z 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 rho one k 1 z k info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 + var-8)) + (setf info var-9)) + (setf rho (* rho rho)) + (dlaset "A" k 1 one one + (f2cl-lib:array-slice work double-float (iwk3) ((1 *))) k) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dlasd4 k j dsigma z + (f2cl-lib:array-slice work double-float (iwk1) ((1 *))) rho + (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) + (f2cl-lib:array-slice work double-float (iwk2) ((1 *))) info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-7)) + (setf (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) var-6) + (setf info var-8)) + (cond + ((/= info 0) + (go end_label))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add iwk3i j)) + ((1 *)) + work-%offset%) + (* + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add iwk3i j)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref work-%data% (j) ((1 *)) work-%offset%) + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add iwk2i j)) + ((1 *)) + work-%offset%))) + (setf (f2cl-lib:fref difl-%data% (j) ((1 *)) difl-%offset%) + (- (f2cl-lib:fref work-%data% (j) ((1 *)) work-%offset%))) + (setf (f2cl-lib:fref difr-%data% + (j 1) + ((1 lddifr) (1 *)) + difr-%offset%) + (- + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j 1)) + ((1 *)) + work-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add iwk3i i)) + ((1 *)) + work-%offset%) + (/ + (/ + (* + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add iwk3i i)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref work-%data% + (i) + ((1 *)) + work-%offset%) + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add iwk2i i)) + ((1 *)) + work-%offset%)) + (- + (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + (f2cl-lib:fref dsigma-%data% + (j) + ((1 *)) + dsigma-%offset%))) + (+ + (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + (f2cl-lib:fref dsigma-%data% + (j) + ((1 *)) + dsigma-%offset%)))))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) (f2cl-lib:int-add i 1)) + ((> i k) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add iwk3i i)) + ((1 *)) + work-%offset%) + (/ + (/ + (* + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add iwk3i i)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref work-%data% + (i) + ((1 *)) + work-%offset%) + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add iwk2i i)) + ((1 *)) + work-%offset%)) + (- + (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + (f2cl-lib:fref dsigma-%data% + (j) + ((1 *)) + dsigma-%offset%))) + (+ + (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + (f2cl-lib:fref dsigma-%data% + (j) + ((1 *)) + dsigma-%offset%)))))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i k) nil) + (tagbody + (setf (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%) + (f2cl-lib:sign + (f2cl-lib:fsqrt + (abs + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add iwk3i i)) + ((1 *)) + work-%offset%))) + (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%))))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j k) nil) + (tagbody + (setf diflj (f2cl-lib:fref difl-%data% (j) ((1 *)) difl-%offset%)) + (setf dj (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%)) + (setf dsigj + (- + (f2cl-lib:fref dsigma-%data% + (j) + ((1 *)) + dsigma-%offset%))) + (cond + ((< j k) + (setf difrj + (- + (f2cl-lib:fref difr-%data% + (j 1) + ((1 lddifr) (1 *)) + difr-%offset%))) + (setf dsigjp + (- + (f2cl-lib:fref dsigma-%data% + ((f2cl-lib:int-add j 1)) + ((1 *)) + dsigma-%offset%))))) + (setf (f2cl-lib:fref work-%data% (j) ((1 *)) work-%offset%) + (/ + (/ (- (f2cl-lib:fref z-%data% (j) ((1 *)) z-%offset%)) + diflj) + (+ + (f2cl-lib:fref dsigma-%data% (j) ((1 *)) dsigma-%offset%) + dj))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) + (/ + (/ (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%) + (- + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 + (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + dsigj) + (declare (ignore)) + (setf (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + var-0) + (setf dsigj var-1) + ret-val) + diflj)) + (+ + (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + dj))))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) (f2cl-lib:int-add i 1)) + ((> i k) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) + (/ + (/ (f2cl-lib:fref z-%data% (i) ((1 *)) z-%offset%) + (+ + (multiple-value-bind (ret-val var-0 var-1) + (dlamc3 + (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + dsigjp) + (declare (ignore)) + (setf (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + var-0) + (setf dsigjp var-1) + ret-val) + difrj)) + (+ + (f2cl-lib:fref dsigma-%data% + (i) + ((1 *)) + dsigma-%offset%) + dj))))) + (setf temp (dnrm2 k work 1)) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add iwk2i j)) + ((1 *)) + work-%offset%) + (/ (ddot k work 1 vf 1) temp)) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add iwk3i j)) + ((1 *)) + work-%offset%) + (/ (ddot k work 1 vl 1) temp)) + (cond + ((= icompq 1) + (setf (f2cl-lib:fref difr-%data% + (j 2) + ((1 lddifr) (1 *)) + difr-%offset%) + temp))))) + (dcopy k (f2cl-lib:array-slice work double-float (iwk2) ((1 *))) 1 vf 1) + (dcopy k (f2cl-lib:array-slice work double-float (iwk3) ((1 *))) 1 vl 1) + end_label + (return (values 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::dlasd8 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (array double-float (*)) (array double-float (*)) + (array double-float (*)) (array double-float (*)) + (array double-float (*)) (array double-float (*)) + fixnum (array double-float (*)) + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dcopy fortran-to-lisp::ddot + fortran-to-lisp::dlasd4 fortran-to-lisp::dlaset + fortran-to-lisp::dlascl fortran-to-lisp::dnrm2 + fortran-to-lisp::dlamc3 fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasda LAPACK} +\pagehead{dlasda}{dlasda} +%\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 dlasda + (icompq smlsiz n sqre d e u ldu vt k difl difr z poles givptr givcol + ldgcol perm givnum c s work iwork info) + (declare (type (array fixnum (*)) iwork perm givcol givptr k) + (type (array double-float (*)) work s c givnum poles z difr difl + vt u e d) + (type fixnum info ldgcol ldu sqre n smlsiz icompq)) + (f2cl-lib:with-multi-array-data + ((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%) + (difl double-float difl-%data% difl-%offset%) + (difr double-float difr-%data% difr-%offset%) + (z double-float z-%data% z-%offset%) + (poles double-float poles-%data% poles-%offset%) + (givnum double-float givnum-%data% givnum-%offset%) + (c double-float c-%data% c-%offset%) + (s double-float s-%data% s-%offset%) + (work double-float work-%data% work-%offset%) + (k fixnum k-%data% k-%offset%) + (givptr fixnum givptr-%data% givptr-%offset%) + (givcol fixnum givcol-%data% givcol-%offset%) + (perm fixnum perm-%data% perm-%offset%) + (iwork fixnum iwork-%data% iwork-%offset%)) + (prog ((alpha 0.0) (beta 0.0) (i 0) (i1 0) (ic 0) (idxq 0) (idxqi 0) + (im1 0) (inode 0) (itemp 0) (iwk 0) (j 0) (lf 0) (ll 0) (lvl 0) + (lvl2 0) (m 0) (ncc 0) (nd 0) (ndb1 0) (ndiml 0) (ndimr 0) (nl 0) + (nlf 0) (nlp1 0) (nlvl 0) (nr 0) (nrf 0) (nrp1 0) (nru 0) + (nwork1 0) (nwork2 0) (smlszp 0) (sqrei 0) (vf 0) (vfi 0) (vl 0) + (vli 0)) + (declare (type (double-float) alpha beta) + (type fixnum i i1 ic idxq idxqi im1 inode itemp + iwk j lf ll lvl lvl2 m ncc nd ndb1 + ndiml ndimr nl nlf nlp1 nlvl nr nrf + nrp1 nru nwork1 nwork2 smlszp sqrei + vf vfi vl vli)) + (setf info 0) + (cond + ((or (< icompq 0) (> icompq 1)) + (setf info -1)) + ((< smlsiz 3) + (setf info -2)) + ((< n 0) + (setf info -3)) + ((or (< sqre 0) (> sqre 1)) + (setf info -4)) + ((< ldu (f2cl-lib:int-add n sqre)) + (setf info -8)) + ((< ldgcol n) + (setf info -17))) + (cond + ((/= info 0) + (xerbla "DLASDA" (f2cl-lib:int-sub info)) + (go end_label))) + (setf m (f2cl-lib:int-add n sqre)) + (cond + ((<= n smlsiz) + (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" sqre n 0 0 0 d e vt ldu u ldu u ldu work 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))) + (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) + (dlasdq "U" sqre n m n 0 d e vt ldu u ldu u ldu work 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 end_label))) + (setf inode 1) + (setf ndiml (f2cl-lib:int-add inode n)) + (setf ndimr (f2cl-lib:int-add ndiml n)) + (setf idxq (f2cl-lib:int-add ndimr n)) + (setf iwk (f2cl-lib:int-add idxq n)) + (setf ncc 0) + (setf nru 0) + (setf smlszp (f2cl-lib:int-add smlsiz 1)) + (setf vf 1) + (setf vl (f2cl-lib:int-add vf m)) + (setf nwork1 (f2cl-lib:int-add vl m)) + (setf nwork2 + (f2cl-lib:int-add nwork1 (f2cl-lib:int-mul smlszp smlszp))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6) + (dlasdt n nlvl nd + (f2cl-lib:array-slice iwork fixnum (inode) ((1 *))) + (f2cl-lib:array-slice iwork fixnum (ndiml) ((1 *))) + (f2cl-lib:array-slice iwork fixnum (ndimr) ((1 *))) + smlsiz) + (declare (ignore var-0 var-3 var-4 var-5 var-6)) + (setf nlvl var-1) + (setf nd var-2)) + (setf ndb1 (the fixnum (truncate (+ nd 1) 2))) + (f2cl-lib:fdo (i ndb1 (f2cl-lib:int-add i 1)) + ((> i nd) nil) + (tagbody + (setf i1 (f2cl-lib:int-sub i 1)) + (setf ic + (f2cl-lib:fref iwork-%data% + ((f2cl-lib:int-add inode i1)) + ((1 *)) + iwork-%offset%)) + (setf nl + (f2cl-lib:fref iwork-%data% + ((f2cl-lib:int-add ndiml i1)) + ((1 *)) + iwork-%offset%)) + (setf nlp1 (f2cl-lib:int-add nl 1)) + (setf nr + (f2cl-lib:fref iwork-%data% + ((f2cl-lib:int-add ndimr i1)) + ((1 *)) + iwork-%offset%)) + (setf nlf (f2cl-lib:int-sub ic nl)) + (setf nrf (f2cl-lib:int-add ic 1)) + (setf idxqi (f2cl-lib:int-sub (f2cl-lib:int-add idxq nlf) 2)) + (setf vfi (f2cl-lib:int-sub (f2cl-lib:int-add vf nlf) 1)) + (setf vli (f2cl-lib:int-sub (f2cl-lib:int-add vl nlf) 1)) + (setf sqrei 1) + (cond + ((= icompq 0) + (dlaset "A" nlp1 nlp1 zero one + (f2cl-lib:array-slice work double-float (nwork1) ((1 *))) + smlszp) + (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" sqrei nl nlp1 nru ncc + (f2cl-lib:array-slice d double-float (nlf) ((1 *))) + (f2cl-lib:array-slice e double-float (nlf) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork1) ((1 *))) + smlszp + (f2cl-lib:array-slice work double-float (nwork2) ((1 *))) + nl + (f2cl-lib:array-slice work double-float (nwork2) ((1 *))) + nl + (f2cl-lib:array-slice work double-float (nwork2) ((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)) + (setf itemp + (f2cl-lib:int-add nwork1 (f2cl-lib:int-mul nl smlszp))) + (dcopy nlp1 + (f2cl-lib:array-slice work double-float (nwork1) ((1 *))) 1 + (f2cl-lib:array-slice work double-float (vfi) ((1 *))) 1) + (dcopy nlp1 + (f2cl-lib:array-slice work double-float (itemp) ((1 *))) 1 + (f2cl-lib:array-slice work double-float (vli) ((1 *))) 1)) + (t + (dlaset "A" nl nl zero one + (f2cl-lib:array-slice u double-float (nlf 1) ((1 ldu) (1 *))) + ldu) + (dlaset "A" nlp1 nlp1 zero one + (f2cl-lib:array-slice vt double-float (nlf 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 var-14 var-15) + (dlasdq "U" sqrei nl nlp1 nl ncc + (f2cl-lib:array-slice d double-float (nlf) ((1 *))) + (f2cl-lib:array-slice e double-float (nlf) ((1 *))) + (f2cl-lib:array-slice vt + double-float + (nlf 1) + ((1 ldu) (1 *))) + ldu + (f2cl-lib:array-slice u + double-float + (nlf 1) + ((1 ldu) (1 *))) + ldu + (f2cl-lib:array-slice u + double-float + (nlf 1) + ((1 ldu) (1 *))) + ldu + (f2cl-lib:array-slice work double-float (nwork1) ((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)) + (dcopy nlp1 + (f2cl-lib:array-slice vt double-float (nlf 1) ((1 ldu) (1 *))) + 1 (f2cl-lib:array-slice work double-float (vfi) ((1 *))) 1) + (dcopy nlp1 + (f2cl-lib:array-slice vt + double-float + (nlf nlp1) + ((1 ldu) (1 *))) + 1 (f2cl-lib:array-slice work double-float (vli) ((1 *))) 1))) + (cond + ((/= info 0) + (go end_label))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j nl) nil) + (tagbody + (setf (f2cl-lib:fref iwork-%data% + ((f2cl-lib:int-add idxqi j)) + ((1 *)) + iwork-%offset%) + j))) + (cond + ((and (= i nd) (= sqre 0)) + (setf sqrei 0)) + (t + (setf sqrei 1))) + (setf idxqi (f2cl-lib:int-add idxqi nlp1)) + (setf vfi (f2cl-lib:int-add vfi nlp1)) + (setf vli (f2cl-lib:int-add vli nlp1)) + (setf nrp1 (f2cl-lib:int-add nr sqrei)) + (cond + ((= icompq 0) + (dlaset "A" nrp1 nrp1 zero one + (f2cl-lib:array-slice work double-float (nwork1) ((1 *))) + smlszp) + (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" sqrei nr nrp1 nru ncc + (f2cl-lib:array-slice d double-float (nrf) ((1 *))) + (f2cl-lib:array-slice e double-float (nrf) ((1 *))) + (f2cl-lib:array-slice work double-float (nwork1) ((1 *))) + smlszp + (f2cl-lib:array-slice work double-float (nwork2) ((1 *))) + nr + (f2cl-lib:array-slice work double-float (nwork2) ((1 *))) + nr + (f2cl-lib:array-slice work double-float (nwork2) ((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)) + (setf itemp + (f2cl-lib:int-add nwork1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub nrp1 1) + smlszp))) + (dcopy nrp1 + (f2cl-lib:array-slice work double-float (nwork1) ((1 *))) 1 + (f2cl-lib:array-slice work double-float (vfi) ((1 *))) 1) + (dcopy nrp1 + (f2cl-lib:array-slice work double-float (itemp) ((1 *))) 1 + (f2cl-lib:array-slice work double-float (vli) ((1 *))) 1)) + (t + (dlaset "A" nr nr zero one + (f2cl-lib:array-slice u double-float (nrf 1) ((1 ldu) (1 *))) + ldu) + (dlaset "A" nrp1 nrp1 zero one + (f2cl-lib:array-slice vt double-float (nrf 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 var-14 var-15) + (dlasdq "U" sqrei nr nrp1 nr ncc + (f2cl-lib:array-slice d double-float (nrf) ((1 *))) + (f2cl-lib:array-slice e double-float (nrf) ((1 *))) + (f2cl-lib:array-slice vt + double-float + (nrf 1) + ((1 ldu) (1 *))) + ldu + (f2cl-lib:array-slice u + double-float + (nrf 1) + ((1 ldu) (1 *))) + ldu + (f2cl-lib:array-slice u + double-float + (nrf 1) + ((1 ldu) (1 *))) + ldu + (f2cl-lib:array-slice work double-float (nwork1) ((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)) + (dcopy nrp1 + (f2cl-lib:array-slice vt double-float (nrf 1) ((1 ldu) (1 *))) + 1 (f2cl-lib:array-slice work double-float (vfi) ((1 *))) 1) + (dcopy nrp1 + (f2cl-lib:array-slice vt + double-float + (nrf nrp1) + ((1 ldu) (1 *))) + 1 (f2cl-lib:array-slice work double-float (vli) ((1 *))) 1))) + (cond + ((/= info 0) + (go end_label))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j nr) nil) + (tagbody + (setf (f2cl-lib:fref iwork-%data% + ((f2cl-lib:int-add idxqi j)) + ((1 *)) + iwork-%offset%) + j))))) + (setf j (expt 2 nlvl)) + (f2cl-lib:fdo (lvl nlvl (f2cl-lib:int-add lvl (f2cl-lib:int-sub 1))) + ((> lvl 1) nil) + (tagbody + (setf lvl2 (f2cl-lib:int-sub (f2cl-lib:int-mul lvl 2) 1)) + (cond + ((= lvl 1) + (setf lf 1) + (setf ll 1)) + (t + (setf lf (expt 2 (f2cl-lib:int-sub lvl 1))) + (setf ll (f2cl-lib:int-sub (f2cl-lib:int-mul 2 lf) 1)))) + (f2cl-lib:fdo (i lf (f2cl-lib:int-add i 1)) + ((> i ll) nil) + (tagbody + (setf im1 (f2cl-lib:int-sub i 1)) + (setf ic + (f2cl-lib:fref iwork-%data% + ((f2cl-lib:int-add inode im1)) + ((1 *)) + iwork-%offset%)) + (setf nl + (f2cl-lib:fref iwork-%data% + ((f2cl-lib:int-add ndiml im1)) + ((1 *)) + iwork-%offset%)) + (setf nr + (f2cl-lib:fref iwork-%data% + ((f2cl-lib:int-add ndimr im1)) + ((1 *)) + iwork-%offset%)) + (setf nlf (f2cl-lib:int-sub ic nl)) + (setf nrf (f2cl-lib:int-add ic 1)) + (cond + ((= i ll) + (setf sqrei sqre)) + (t + (setf sqrei 1))) + (setf vfi (f2cl-lib:int-sub (f2cl-lib:int-add vf nlf) 1)) + (setf vli (f2cl-lib:int-sub (f2cl-lib:int-add vl nlf) 1)) + (setf idxqi (f2cl-lib:int-sub (f2cl-lib:int-add idxq nlf) 1)) + (setf alpha (f2cl-lib:fref d-%data% (ic) ((1 *)) d-%offset%)) + (setf beta (f2cl-lib:fref e-%data% (ic) ((1 *)) e-%offset%)) + (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 + var-16 var-17 var-18 var-19 var-20 var-21 var-22 + var-23 var-24 var-25) + (dlasd6 icompq nl nr sqrei + (f2cl-lib:array-slice d double-float (nlf) ((1 *))) + (f2cl-lib:array-slice work double-float (vfi) ((1 *))) + (f2cl-lib:array-slice work double-float (vli) ((1 *))) + alpha beta + (f2cl-lib:array-slice iwork + fixnum + (idxqi) + ((1 *))) + perm + (f2cl-lib:fref givptr-%data% + (1) + ((1 *)) + givptr-%offset%) + givcol ldgcol givnum ldu poles difl difr z + (f2cl-lib:fref k-%data% (1) ((1 *)) k-%offset%) + (f2cl-lib:fref c-%data% (1) ((1 *)) c-%offset%) + (f2cl-lib:fref s-%data% (1) ((1 *)) s-%offset%) + (f2cl-lib:array-slice work + double-float + (nwork1) + ((1 *))) + (f2cl-lib:array-slice iwork + fixnum + (iwk) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-9 var-10 var-12 var-13 var-14 var-15 + var-16 var-17 var-18 var-19 var-23 + var-24)) + (setf alpha var-7) + (setf beta var-8) + (setf (f2cl-lib:fref givptr-%data% + (1) + ((1 *)) + givptr-%offset%) + var-11) + (setf (f2cl-lib:fref k-%data% (1) ((1 *)) k-%offset%) + var-20) + (setf (f2cl-lib:fref c-%data% (1) ((1 *)) c-%offset%) + var-21) + (setf (f2cl-lib:fref s-%data% (1) ((1 *)) s-%offset%) + var-22) + (setf info var-25))) + (t + (setf j (f2cl-lib:int-sub j 1)) + (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 var-24 var-25) + (dlasd6 icompq nl nr sqrei + (f2cl-lib:array-slice d double-float (nlf) ((1 *))) + (f2cl-lib:array-slice work double-float (vfi) ((1 *))) + (f2cl-lib:array-slice work double-float (vli) ((1 *))) + alpha beta + (f2cl-lib:array-slice iwork + fixnum + (idxqi) + ((1 *))) + (f2cl-lib:array-slice perm + fixnum + (nlf lvl) + ((1 ldgcol) (1 *))) + (f2cl-lib:fref givptr-%data% + (j) + ((1 *)) + givptr-%offset%) + (f2cl-lib:array-slice givcol + fixnum + (nlf lvl2) + ((1 ldgcol) (1 *))) + ldgcol + (f2cl-lib:array-slice givnum + double-float + (nlf lvl2) + ((1 ldu) (1 *))) + ldu + (f2cl-lib:array-slice poles + double-float + (nlf lvl2) + ((1 ldu) (1 *))) + (f2cl-lib:array-slice difl + double-float + (nlf lvl) + ((1 ldu) (1 *))) + (f2cl-lib:array-slice difr + double-float + (nlf lvl2) + ((1 ldu) (1 *))) + (f2cl-lib:array-slice z + double-float + (nlf lvl) + ((1 ldu) (1 *))) + (f2cl-lib:fref k-%data% (j) ((1 *)) k-%offset%) + (f2cl-lib:fref c-%data% (j) ((1 *)) c-%offset%) + (f2cl-lib:fref s-%data% (j) ((1 *)) s-%offset%) + (f2cl-lib:array-slice work + double-float + (nwork1) + ((1 *))) + (f2cl-lib:array-slice iwork + fixnum + (iwk) + ((1 *))) + info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-9 var-10 var-12 var-13 var-14 var-15 + var-16 var-17 var-18 var-19 var-23 + var-24)) + (setf alpha var-7) + (setf beta var-8) + (setf (f2cl-lib:fref givptr-%data% + (j) + ((1 *)) + givptr-%offset%) + var-11) + (setf (f2cl-lib:fref k-%data% (j) ((1 *)) k-%offset%) + var-20) + (setf (f2cl-lib:fref c-%data% (j) ((1 *)) c-%offset%) + var-21) + (setf (f2cl-lib:fref s-%data% (j) ((1 *)) s-%offset%) + var-22) + (setf info var-25)))) + (cond + ((/= info 0) + (go end_label))))))) + end_label + (return + (values nil + nil + nil + nil + nil + nil + nil + nil + nil + 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::dlasda + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + fixnum fixnum + (array double-float (*)) (array double-float (*)) + (array double-float (*)) fixnum + (array double-float (*)) + (array fixnum (*)) + (array double-float (*)) (array double-float (*)) + (array double-float (*)) (array double-float (*)) + (array fixnum (*)) + (array fixnum (*)) + fixnum + (array fixnum (*)) + (array double-float (*)) (array double-float (*)) + (array double-float (*)) (array double-float (*)) + (array fixnum (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlasdt fortran-to-lisp::dlasd6 + fortran-to-lisp::dcopy fortran-to-lisp::dlaset + fortran-to-lisp::dlasdq fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasdq LAPACK} +\pagehead{dlasdq}{dlasdq} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dlasdq (uplo sqre 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 sqre) + (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 ((cs 0.0) (r 0.0) (smin 0.0) (sn 0.0) (i 0) (isub 0) (iuplo 0) + (j 0) (np1 0) (sqre1 0) (rotate nil)) + (declare (type (double-float) cs r smin sn) + (type fixnum i isub iuplo j np1 sqre1) + (type (member t nil) rotate)) + (setf info 0) + (setf iuplo 0) + (if (lsame uplo "U") (setf iuplo 1)) + (if (lsame uplo "L") (setf iuplo 2)) + (cond + ((= iuplo 0) + (setf info -1)) + ((or (< sqre 0) (> sqre 1)) + (setf info -2)) + ((< n 0) + (setf info -3)) + ((< ncvt 0) + (setf info -4)) + ((< nru 0) + (setf info -5)) + ((< ncc 0) + (setf info -6)) + ((or (and (= ncvt 0) (< ldvt 1)) + (and (> ncvt 0) + (< ldvt + (max (the fixnum 1) + (the fixnum n))))) + (setf info -10)) + ((< ldu (max (the fixnum 1) (the fixnum nru))) + (setf info -12)) + ((or (and (= ncc 0) (< ldc 1)) + (and (> ncc 0) + (< ldc + (max (the fixnum 1) + (the fixnum n))))) + (setf info -14))) + (cond + ((/= info 0) + (xerbla "DLASDQ" (f2cl-lib:int-sub info)) + (go end_label))) + (if (= n 0) (go end_label)) + (setf rotate (or (> ncvt 0) (> nru 0) (> ncc 0))) + (setf np1 (f2cl-lib:int-add n 1)) + (setf sqre1 sqre) + (cond + ((and (= iuplo 1) (= sqre1 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 + (rotate + (setf (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) + cs) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add n i)) + ((1 *)) + work-%offset%) + sn))))) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlartg (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%) + (f2cl-lib:fref e-%data% (n) ((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% (n) ((1 *)) d-%offset%) r) + (setf (f2cl-lib:fref e-%data% (n) ((1 *)) e-%offset%) zero) + (cond + (rotate + (setf (f2cl-lib:fref work-%data% (n) ((1 *)) work-%offset%) cs) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add n n)) + ((1 *)) + work-%offset%) + sn))) + (setf iuplo 2) + (setf sqre1 0) + (if (> ncvt 0) + (dlasr "L" "V" "F" np1 ncvt + (f2cl-lib:array-slice work double-float (1) ((1 *))) + (f2cl-lib:array-slice work double-float (np1) ((1 *))) vt + ldvt)))) + (cond + ((= iuplo 2) + (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 + (rotate + (setf (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) + cs) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add n i)) + ((1 *)) + work-%offset%) + sn))))) + (cond + ((= sqre1 1) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlartg (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%) + (f2cl-lib:fref e-%data% (n) ((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% (n) ((1 *)) d-%offset%) r) + (cond + (rotate + (setf (f2cl-lib:fref work-%data% (n) ((1 *)) work-%offset%) cs) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add n n)) + ((1 *)) + work-%offset%) + sn))))) + (cond + ((> nru 0) + (cond + ((= sqre1 0) + (dlasr "R" "V" "F" nru n + (f2cl-lib:array-slice work double-float (1) ((1 *))) + (f2cl-lib:array-slice work double-float (np1) ((1 *))) u ldu)) + (t + (dlasr "R" "V" "F" nru np1 + (f2cl-lib:array-slice work double-float (1) ((1 *))) + (f2cl-lib:array-slice work double-float (np1) ((1 *))) u + ldu))))) + (cond + ((> ncc 0) + (cond + ((= sqre1 0) + (dlasr "L" "V" "F" n ncc + (f2cl-lib:array-slice work double-float (1) ((1 *))) + (f2cl-lib:array-slice work double-float (np1) ((1 *))) c ldc)) + (t + (dlasr "L" "V" "F" np1 ncc + (f2cl-lib:array-slice work double-float (1) ((1 *))) + (f2cl-lib:array-slice work double-float (np1) ((1 *))) c + ldc))))))) + (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 ncc d e vt ldvt u ldu c ldc work 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)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf isub i) + (setf smin (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) + (f2cl-lib:fdo (j (f2cl-lib:int-add i 1) (f2cl-lib:int-add j 1)) + ((> j n) 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 i) + (setf (f2cl-lib:fref d-%data% (isub) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) + (setf (f2cl-lib:fref d-%data% (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 + (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 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 (i 1) ((1 ldc) (1 *))) + ldc)))))) + end_label + (return + (values nil + 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::dlasdq + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum 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 nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::dswap fortran-to-lisp::dbdsqr + fortran-to-lisp::dlasr fortran-to-lisp::dlartg + fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasdt LAPACK} +\pagehead{dlasdt}{dlasdt} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((two 2.0)) + (declare (type (double-float 2.0 2.0) two)) + (defun dlasdt (n lvl nd inode ndiml ndimr msub) + (declare (type (array fixnum (*)) ndimr ndiml inode) + (type fixnum msub nd lvl n)) + (f2cl-lib:with-multi-array-data + ((inode fixnum inode-%data% inode-%offset%) + (ndiml fixnum ndiml-%data% ndiml-%offset%) + (ndimr fixnum ndimr-%data% ndimr-%offset%)) + (prog ((temp 0.0) (i 0) (il 0) (ir 0) (llst 0) (maxn 0) (ncrnt 0) + (nlvl 0)) + (declare (type (double-float) temp) + (type fixnum i il ir llst maxn ncrnt nlvl)) + (setf maxn (max (the fixnum 1) (the fixnum n))) + (setf temp + (/ + (f2cl-lib:flog + (/ (coerce (realpart maxn) 'double-float) + (coerce (realpart (f2cl-lib:int-add msub 1)) 'double-float))) + (f2cl-lib:flog two))) + (setf lvl (f2cl-lib:int-add (f2cl-lib:int temp) 1)) + (setf i (the fixnum (truncate n 2))) + (setf (f2cl-lib:fref inode-%data% (1) ((1 *)) inode-%offset%) + (f2cl-lib:int-add i 1)) + (setf (f2cl-lib:fref ndiml-%data% (1) ((1 *)) ndiml-%offset%) i) + (setf (f2cl-lib:fref ndimr-%data% (1) ((1 *)) ndimr-%offset%) + (f2cl-lib:int-sub n i 1)) + (setf il 0) + (setf ir 1) + (setf llst 1) + (f2cl-lib:fdo (nlvl 1 (f2cl-lib:int-add nlvl 1)) + ((> nlvl (f2cl-lib:int-add lvl (f2cl-lib:int-sub 1))) nil) + (tagbody + (f2cl-lib:fdo (i 0 (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add llst (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf il (f2cl-lib:int-add il 2)) + (setf ir (f2cl-lib:int-add ir 2)) + (setf ncrnt (f2cl-lib:int-add llst i)) + (setf (f2cl-lib:fref ndiml-%data% (il) ((1 *)) ndiml-%offset%) + (the fixnum + (truncate + (f2cl-lib:fref ndiml-%data% + (ncrnt) + ((1 *)) + ndiml-%offset%) + 2))) + (setf (f2cl-lib:fref ndimr-%data% (il) ((1 *)) ndimr-%offset%) + (f2cl-lib:int-sub + (f2cl-lib:fref ndiml-%data% + (ncrnt) + ((1 *)) + ndiml-%offset%) + (f2cl-lib:fref ndiml-%data% + (il) + ((1 *)) + ndiml-%offset%) + 1)) + (setf (f2cl-lib:fref inode-%data% (il) ((1 *)) inode-%offset%) + (f2cl-lib:int-sub + (f2cl-lib:fref inode-%data% + (ncrnt) + ((1 *)) + inode-%offset%) + (f2cl-lib:fref ndimr-%data% + (il) + ((1 *)) + ndimr-%offset%) + 1)) + (setf (f2cl-lib:fref ndiml-%data% (ir) ((1 *)) ndiml-%offset%) + (the fixnum + (truncate + (f2cl-lib:fref ndimr-%data% + (ncrnt) + ((1 *)) + ndimr-%offset%) + 2))) + (setf (f2cl-lib:fref ndimr-%data% (ir) ((1 *)) ndimr-%offset%) + (f2cl-lib:int-sub + (f2cl-lib:fref ndimr-%data% + (ncrnt) + ((1 *)) + ndimr-%offset%) + (f2cl-lib:fref ndiml-%data% + (ir) + ((1 *)) + ndiml-%offset%) + 1)) + (setf (f2cl-lib:fref inode-%data% (ir) ((1 *)) inode-%offset%) + (f2cl-lib:int-add + (f2cl-lib:fref inode-%data% + (ncrnt) + ((1 *)) + inode-%offset%) + (f2cl-lib:fref ndiml-%data% + (ir) + ((1 *)) + ndiml-%offset%) + 1)))) + (setf llst (f2cl-lib:int-mul llst 2)))) + (setf nd (f2cl-lib:int-sub (f2cl-lib:int-mul llst 2) 1)) + end_label + (return (values nil lvl nd 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::dlasdt + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + fixnum + (array fixnum (*)) + (array fixnum (*)) + (array fixnum (*)) + fixnum) + :return-values '(nil fortran-to-lisp::lvl fortran-to-lisp::nd nil + nil nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlaset LAPACK} +\pagehead{dlaset}{dlaset} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun dlaset (uplo m n alpha beta a lda) + (declare (type (array double-float (*)) a) + (type (double-float) beta alpha) + (type fixnum 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%)) + (prog ((i 0) (j 0)) + (declare (type fixnum j i)) + (cond + ((lsame uplo "U") + (f2cl-lib:fdo (j 2 (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 + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + (the fixnum m))) + nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + alpha)))))) + ((lsame uplo "L") + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j + (min (the fixnum m) + (the fixnum n))) + nil) + (tagbody + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + alpha)))))) + (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 a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + alpha))))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum m) + (the fixnum n))) + nil) + (tagbody + (setf (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) beta))) + (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::dlaset + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum fixnum + (double-float) (double-float) (array double-float (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasq1 LAPACK} +\pagehead{dlasq1}{dlasq1} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dlasq1 (n d e work info) + (declare (type (array double-float (*)) work e d) + (type fixnum info n)) + (f2cl-lib:with-multi-array-data + ((d double-float d-%data% d-%offset%) + (e double-float e-%data% e-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((eps 0.0) (scale 0.0) (safmin 0.0) (sigmn 0.0) (sigmx 0.0) (i 0) + (iinfo 0)) + (declare (type (double-float) eps scale safmin sigmn sigmx) + (type fixnum i iinfo)) + (setf info 0) + (cond + ((< n 0) + (setf info -2) + (xerbla "DLASQ1" (f2cl-lib:int-sub info)) + (go end_label)) + ((= n 0) + (go end_label)) + ((= n 1) + (setf (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%) + (abs (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%))) + (go end_label)) + ((= n 2) + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (dlas2 (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%) + (f2cl-lib:fref e-%data% (1) ((1 *)) e-%offset%) + (f2cl-lib:fref d-%data% (2) ((1 *)) d-%offset%) sigmn sigmx) + (declare (ignore var-0 var-1 var-2)) + (setf sigmn var-3) + (setf sigmx var-4)) + (setf (f2cl-lib:fref d-%data% (1) ((1 *)) d-%offset%) sigmx) + (setf (f2cl-lib:fref d-%data% (2) ((1 *)) d-%offset%) sigmn) + (go end_label))) + (setf sigmx zero) + (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 (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + (abs (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%))) + (setf sigmx + (max sigmx + (abs + (f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%)))))) + (setf (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%) + (abs (f2cl-lib:fref d-%data% (n) ((1 *)) d-%offset%))) + (cond + ((= sigmx zero) + (multiple-value-bind (var-0 var-1 var-2 var-3) + (dlasrt "D" n d iinfo) + (declare (ignore var-0 var-1 var-2)) + (setf iinfo var-3)) + (go end_label))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf sigmx + (max sigmx + (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%))))) + (setf eps (dlamch "Precision")) + (setf safmin (dlamch "Safe minimum")) + (setf scale (f2cl-lib:fsqrt (/ eps safmin))) + (dcopy n d 1 (f2cl-lib:array-slice work double-float (1) ((1 *))) 2) + (dcopy (f2cl-lib:int-sub n 1) e 1 + (f2cl-lib:array-slice work double-float (2) ((1 *))) 2) + (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 sigmx scale + (f2cl-lib:int-sub (f2cl-lib:int-mul 2 n) 1) 1 work + (f2cl-lib:int-sub (f2cl-lib:int-mul 2 n) 1) 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)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add (f2cl-lib:int-mul 2 n) + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) + (expt (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) + 2)))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-mul 2 n)) + ((1 *)) + work-%offset%) + zero) + (multiple-value-bind (var-0 var-1 var-2) + (dlasq2 n work info) + (declare (ignore var-0 var-1)) + (setf info var-2)) + (cond + ((= info 0) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + (f2cl-lib:fsqrt + (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%))))) + (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 scale sigmx n 1 d n 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)))) + end_label + (return (values 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::dlasq1 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum (array double-float (*)) + (array double-float (*)) (array double-float (*)) + fixnum) + :return-values '(nil nil nil nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlasq2 fortran-to-lisp::dlascl + fortran-to-lisp::dcopy fortran-to-lisp::dlamch + fortran-to-lisp::dlasrt fortran-to-lisp::dlas2 + fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasq2 LAPACK} +\pagehead{dlasq2}{dlasq2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((cbias 1.5) + (zero 0.0) + (half 0.5) + (one 1.0) + (two 2.0) + (four 4.0) + (hundrd 100.0)) + (declare (type (double-float 1.5 1.5) cbias) + (type (double-float 0.0 0.0) zero) + (type (double-float 0.5 0.5) half) + (type (double-float 1.0 1.0) one) + (type (double-float 2.0 2.0) two) + (type (double-float 4.0 4.0) four) + (type (double-float 100.0 100.0) hundrd)) + (defun dlasq2 (n z info) + (declare (type (array double-float (*)) z) + (type fixnum info n)) + (f2cl-lib:with-multi-array-data + ((z double-float z-%data% z-%offset%)) + (prog ((d 0.0) (desig 0.0) (dmin 0.0) (e 0.0) (emax 0.0) (emin 0.0) + (eps 0.0) (oldemn 0.0) (qmax 0.0) (qmin 0.0) (s 0.0) (safmin 0.0) + (sigma 0.0) (temp 0.0) (tol 0.0) (tol2 0.0) (zmax 0.0) (i0 0) + (i4 0) (iinfo 0) (ipn4 0) (iter 0) (iwhila 0) (iwhilb 0) (k 0) + (n0 0) (nbig 0) (ndiv 0) (nfail 0) (pp 0) (splt 0) (ieee nil) + (trace$ 0.0) (t$ 0.0)) + (declare (type (double-float) t$ trace$ d desig dmin e emax emin eps + oldemn qmax qmin s safmin sigma temp tol + tol2 zmax) + (type fixnum i0 i4 iinfo ipn4 iter iwhila iwhilb + k n0 nbig ndiv nfail pp splt) + (type (member t nil) ieee)) + (setf info 0) + (setf eps (dlamch "Precision")) + (setf safmin (dlamch "Safe minimum")) + (setf tol (* eps hundrd)) + (setf tol2 (expt tol 2)) + (cond + ((< n 0) + (setf info -1) + (xerbla "DLASQ2" 1) + (go end_label)) + ((= n 0) + (go end_label)) + ((= n 1) + (cond + ((< (f2cl-lib:fref z (1) ((1 *))) zero) + (setf info -201) + (xerbla "DLASQ2" 2))) + (go end_label)) + ((= n 2) + (cond + ((or (< (f2cl-lib:fref z (2) ((1 *))) zero) + (< (f2cl-lib:fref z (3) ((1 *))) zero)) + (setf info -2) + (xerbla "DLASQ2" 2) + (go end_label)) + ((> (f2cl-lib:fref z (3) ((1 *))) (f2cl-lib:fref z (1) ((1 *)))) + (setf d (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%)) + (setf (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%)) + (setf (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) d))) + (setf (f2cl-lib:fref z-%data% (5) ((1 *)) z-%offset%) + (+ (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%))) + (cond + ((> (f2cl-lib:fref z (2) ((1 *))) + (* (f2cl-lib:fref z (3) ((1 *))) tol2)) + (setf t$ + (* half + (+ + (- (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%)) + (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%)))) + (setf s + (* (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%) + (/ (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%) + t$))) + (cond + ((<= s t$) + (setf s + (* (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%) + (/ (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%) + (* t$ + (+ one (f2cl-lib:fsqrt (+ one (/ s t$))))))))) + (t + (setf s + (* (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%) + (/ (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%) + (+ t$ + (* (f2cl-lib:fsqrt t$) + (f2cl-lib:fsqrt (+ t$ s))))))))) + (setf t$ + (+ (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) + (+ s (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%)))) + (setf (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%) + (* (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%) + (/ (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) + t$))) + (setf (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%) t$))) + (setf (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (3) ((1 *)) z-%offset%)) + (setf (f2cl-lib:fref z-%data% (6) ((1 *)) z-%offset%) + (+ (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% (1) ((1 *)) z-%offset%))) + (go end_label))) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-mul 2 n)) + ((1 *)) + z-%offset%) + zero) + (setf emin (f2cl-lib:fref z-%data% (2) ((1 *)) z-%offset%)) + (setf qmax zero) + (setf zmax zero) + (setf d zero) + (setf e zero) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 2)) + ((> k + (f2cl-lib:int-mul 2 + (f2cl-lib:int-add n + (f2cl-lib:int-sub + 1)))) + nil) + (tagbody + (cond + ((< (f2cl-lib:fref z (k) ((1 *))) zero) + (setf info (f2cl-lib:int-sub (f2cl-lib:int-add 200 k))) + (xerbla "DLASQ2" 2) + (go end_label)) + ((< (f2cl-lib:fref z ((f2cl-lib:int-add k 1)) ((1 *))) zero) + (setf info (f2cl-lib:int-sub (f2cl-lib:int-add 200 k 1))) + (xerbla "DLASQ2" 2) + (go end_label))) + (setf d (+ d (f2cl-lib:fref z-%data% (k) ((1 *)) z-%offset%))) + (setf e + (+ e + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add k 1)) + ((1 *)) + z-%offset%))) + (setf qmax + (max qmax (f2cl-lib:fref z-%data% (k) ((1 *)) z-%offset%))) + (setf emin + (min emin + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add k 1)) + ((1 *)) + z-%offset%))) + (setf zmax + (max qmax + zmax + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add k 1)) + ((1 *)) + z-%offset%))))) + (cond + ((< + (f2cl-lib:fref z + ((f2cl-lib:int-add (f2cl-lib:int-mul 2 n) + (f2cl-lib:int-sub 1))) + ((1 *))) + zero) + (setf info + (f2cl-lib:int-sub + (f2cl-lib:int-sub + (f2cl-lib:int-add 200 (f2cl-lib:int-mul 2 n)) + 1))) + (xerbla "DLASQ2" 2) + (go end_label))) + (setf d + (+ d + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 n) 1)) + ((1 *)) + z-%offset%))) + (setf qmax + (max qmax + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 n) + 1)) + ((1 *)) + z-%offset%))) + (setf zmax (max qmax zmax)) + (cond + ((= e zero) + (f2cl-lib:fdo (k 2 (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (setf (f2cl-lib:fref z-%data% (k) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 k) + 1)) + ((1 *)) + z-%offset%)))) + (multiple-value-bind (var-0 var-1 var-2 var-3) + (dlasrt "D" n z iinfo) + (declare (ignore var-0 var-1 var-2)) + (setf iinfo var-3)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 n) 1)) + ((1 *)) + z-%offset%) + d) + (go end_label))) + (setf trace$ (+ d e)) + (cond + ((= trace$ zero) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 n) 1)) + ((1 *)) + z-%offset%) + zero) + (go end_label))) + (setf ieee + (and (= (ilaenv 10 "DLASQ2" "N" 1 2 3 4) 1) + (= (ilaenv 11 "DLASQ2" "N" 1 2 3 4) 1))) + (f2cl-lib:fdo (k (f2cl-lib:int-mul 2 n) + (f2cl-lib:int-add k (f2cl-lib:int-sub 2))) + ((> k 2) nil) + (tagbody + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-mul 2 k)) + ((1 *)) + z-%offset%) + zero) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 k) 1)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% (k) ((1 *)) z-%offset%)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 k) 2)) + ((1 *)) + z-%offset%) + zero) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 k) 3)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub k 1)) + ((1 *)) + z-%offset%)))) + (setf i0 1) + (setf n0 n) + (cond + ((< + (* cbias + (f2cl-lib:fref z + ((f2cl-lib:int-add (f2cl-lib:int-mul 4 i0) + (f2cl-lib:int-sub 3))) + ((1 *)))) + (f2cl-lib:fref z + ((f2cl-lib:int-add (f2cl-lib:int-mul 4 n0) + (f2cl-lib:int-sub 3))) + ((1 *)))) + (setf ipn4 (f2cl-lib:int-mul 4 (f2cl-lib:int-add i0 n0))) + (f2cl-lib:fdo (i4 (f2cl-lib:int-mul 4 i0) (f2cl-lib:int-add i4 4)) + ((> i4 + (f2cl-lib:int-mul 2 + (f2cl-lib:int-add i0 + n0 + (f2cl-lib:int-sub + 1)))) + nil) + (tagbody + (setf temp + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 3)) + ((1 *)) + z-%offset%)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 3)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub ipn4 i4 3)) + ((1 *)) + z-%offset%)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub ipn4 i4 3)) + ((1 *)) + z-%offset%) + temp) + (setf temp + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 1)) + ((1 *)) + z-%offset%)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 1)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub ipn4 i4 5)) + ((1 *)) + z-%offset%)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub ipn4 i4 5)) + ((1 *)) + z-%offset%) + temp))))) + (setf pp 0) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k 2) nil) + (tagbody + (setf d + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add (f2cl-lib:int-mul 4 n0) + pp) + 3)) + ((1 *)) + z-%offset%)) + (f2cl-lib:fdo (i4 + (f2cl-lib:int-add + (f2cl-lib:int-mul 4 + (f2cl-lib:int-add n0 + (f2cl-lib:int-sub + 1))) + pp) + (f2cl-lib:int-add i4 (f2cl-lib:int-sub 4))) + ((> i4 (f2cl-lib:int-add (f2cl-lib:int-mul 4 i0) pp)) + nil) + (tagbody + (cond + ((<= + (f2cl-lib:fref z + ((f2cl-lib:int-add i4 (f2cl-lib:int-sub 1))) + ((1 *))) + (* tol2 d)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 1)) + ((1 *)) + z-%offset%) + (- zero)) + (setf d + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 3)) + ((1 *)) + z-%offset%))) + (t + (setf d + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 3)) + ((1 *)) + z-%offset%) + (/ d + (+ d + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 1)) + ((1 *)) + z-%offset%))))))))) + (setf emin + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add (f2cl-lib:int-mul 4 i0) + pp + 1)) + ((1 *)) + z-%offset%)) + (setf d + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add (f2cl-lib:int-mul 4 i0) + pp) + 3)) + ((1 *)) + z-%offset%)) + (f2cl-lib:fdo (i4 (f2cl-lib:int-add (f2cl-lib:int-mul 4 i0) pp) + (f2cl-lib:int-add i4 4)) + ((> i4 + (f2cl-lib:int-add + (f2cl-lib:int-mul 4 + (f2cl-lib:int-add n0 + (f2cl-lib:int-sub + 1))) + pp)) + nil) + (tagbody + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add i4 + (f2cl-lib:int-mul -1 + 2 + pp)) + 2)) + ((1 *)) + z-%offset%) + (+ d + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 1)) + ((1 *)) + z-%offset%))) + (cond + ((<= + (f2cl-lib:fref z + ((f2cl-lib:int-add i4 (f2cl-lib:int-sub 1))) + ((1 *))) + (* tol2 d)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 1)) + ((1 *)) + z-%offset%) + (- zero)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add i4 + (f2cl-lib:int-mul + -1 + 2 + pp)) + 2)) + ((1 *)) + z-%offset%) + d) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add i4 + (f2cl-lib:int-mul -1 + 2 + pp))) + ((1 *)) + z-%offset%) + zero) + (setf d + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add i4 1)) + ((1 *)) + z-%offset%))) + ((and + (< + (* safmin + (f2cl-lib:fref z ((f2cl-lib:int-add i4 1)) ((1 *)))) + (f2cl-lib:fref z + ((f2cl-lib:int-add i4 + (f2cl-lib:int-mul -1 + 2 + pp) + (f2cl-lib:int-sub 2))) + ((1 *)))) + (< + (* safmin + (f2cl-lib:fref z + ((f2cl-lib:int-add i4 + (f2cl-lib:int-mul -1 + 2 + pp) + (f2cl-lib:int-sub + 2))) + ((1 *)))) + (f2cl-lib:fref z ((f2cl-lib:int-add i4 1)) ((1 *))))) + (setf temp + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add i4 1)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add i4 + (f2cl-lib:int-mul + -1 + 2 + pp)) + 2)) + ((1 *)) + z-%offset%))) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add i4 + (f2cl-lib:int-mul -1 + 2 + pp))) + ((1 *)) + z-%offset%) + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 1)) + ((1 *)) + z-%offset%) + temp)) + (setf d (* d temp))) + (t + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add i4 + (f2cl-lib:int-mul -1 + 2 + pp))) + ((1 *)) + z-%offset%) + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add i4 1)) + ((1 *)) + z-%offset%) + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 1)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add i4 + (f2cl-lib:int-mul + -1 + 2 + pp)) + 2)) + ((1 *)) + z-%offset%)))) + (setf d + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add i4 1)) + ((1 *)) + z-%offset%) + (/ d + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add i4 + (f2cl-lib:int-mul + -1 + 2 + pp)) + 2)) + ((1 *)) + z-%offset%)))))) + (setf emin + (min emin + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add i4 + (f2cl-lib:int-mul + -1 + 2 + pp))) + ((1 *)) + z-%offset%))))) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 n0) + pp + 2)) + ((1 *)) + z-%offset%) + d) + (setf qmax + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 i0) + pp + 2)) + ((1 *)) + z-%offset%)) + (f2cl-lib:fdo (i4 + (f2cl-lib:int-add (f2cl-lib:int-mul 4 i0) + (f2cl-lib:int-sub pp) + 2) + (f2cl-lib:int-add i4 4)) + ((> i4 + (f2cl-lib:int-add (f2cl-lib:int-mul 4 n0) + (f2cl-lib:int-sub pp) + (f2cl-lib:int-sub 2))) + nil) + (tagbody + (setf qmax + (max qmax + (f2cl-lib:fref z-%data% (i4) ((1 *)) z-%offset%))))) + (setf pp (f2cl-lib:int-sub 1 pp)))) + (setf iter 2) + (setf nfail 0) + (setf ndiv (f2cl-lib:int-mul 2 (f2cl-lib:int-sub n0 i0))) + (f2cl-lib:fdo (iwhila 1 (f2cl-lib:int-add iwhila 1)) + ((> iwhila (f2cl-lib:int-add n 1)) nil) + (tagbody + (if (< n0 1) (go label150)) + (setf desig zero) + (cond + ((= n0 n) + (setf sigma zero)) + (t + (setf sigma + (- + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-mul 4 n0) + 1)) + ((1 *)) + z-%offset%))))) + (cond + ((< sigma zero) + (setf info 1) + (go end_label))) + (setf emax zero) + (cond + ((> n0 i0) + (setf emin + (abs + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-mul 4 n0) + 5)) + ((1 *)) + z-%offset%)))) + (t + (setf emin zero))) + (setf qmin + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 n0) + 3)) + ((1 *)) + z-%offset%)) + (setf qmax qmin) + (f2cl-lib:fdo (i4 (f2cl-lib:int-mul 4 n0) + (f2cl-lib:int-add i4 (f2cl-lib:int-sub 4))) + ((> i4 8) nil) + (tagbody + (if + (<= + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 5)) + ((1 *)) + z-%offset%) + zero) + (go label100)) + (cond + ((>= qmin (* four emax)) + (setf qmin + (min qmin + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 3)) + ((1 *)) + z-%offset%))) + (setf emax + (max emax + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 5)) + ((1 *)) + z-%offset%))))) + (setf qmax + (max qmax + (+ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 7)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 5)) + ((1 *)) + z-%offset%)))) + (setf emin + (min emin + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 5)) + ((1 *)) + z-%offset%))))) + (setf i4 4) + label100 + (setf i0 (the fixnum (truncate i4 4))) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 n0) 1)) + ((1 *)) + z-%offset%) + emin) + (setf dmin + (- + (max zero + (+ qmin + (* (- two) + (f2cl-lib:fsqrt qmin) + (f2cl-lib:fsqrt emax)))))) + (setf pp 0) + (setf nbig + (f2cl-lib:int-mul 30 + (f2cl-lib:int-add + (f2cl-lib:int-sub n0 i0) + 1))) + (f2cl-lib:fdo (iwhilb 1 (f2cl-lib:int-add iwhilb 1)) + ((> iwhilb nbig) nil) + (tagbody + (if (> i0 n0) (go label130)) + (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) + (dlasq3 i0 n0 z pp dmin sigma desig qmax nfail iter ndiv + ieee) + (declare (ignore var-0 var-2 var-3 var-11)) + (setf n0 var-1) + (setf dmin var-4) + (setf sigma var-5) + (setf desig var-6) + (setf qmax var-7) + (setf nfail var-8) + (setf iter var-9) + (setf ndiv var-10)) + (setf pp (f2cl-lib:int-sub 1 pp)) + (cond + ((and (= pp 0) + (>= (f2cl-lib:int-add n0 (f2cl-lib:int-sub i0)) 3)) + (cond + ((or + (<= (f2cl-lib:fref z ((f2cl-lib:int-mul 4 n0)) ((1 *))) + (* tol2 qmax)) + (<= + (f2cl-lib:fref z + ((f2cl-lib:int-add + (f2cl-lib:int-mul 4 n0) + (f2cl-lib:int-sub 1))) + ((1 *))) + (* tol2 sigma))) + (setf splt (f2cl-lib:int-sub i0 1)) + (setf qmax + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-mul 4 i0) + 3)) + ((1 *)) + z-%offset%)) + (setf emin + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-mul 4 i0) + 1)) + ((1 *)) + z-%offset%)) + (setf oldemn + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-mul 4 i0)) + ((1 *)) + z-%offset%)) + (f2cl-lib:fdo (i4 (f2cl-lib:int-mul 4 i0) + (f2cl-lib:int-add i4 4)) + ((> i4 + (f2cl-lib:int-mul 4 + (f2cl-lib:int-add n0 + (f2cl-lib:int-sub + 3)))) + nil) + (tagbody + (cond + ((or + (<= (f2cl-lib:fref z (i4) ((1 *))) + (* tol2 + (f2cl-lib:fref z + ((f2cl-lib:int-add i4 + (f2cl-lib:int-sub + 3))) + ((1 *))))) + (<= + (f2cl-lib:fref z + ((f2cl-lib:int-add i4 + (f2cl-lib:int-sub + 1))) + ((1 *))) + (* tol2 sigma))) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 1)) + ((1 *)) + z-%offset%) + (- sigma)) + (setf splt (the fixnum (truncate i4 4))) + (setf qmax zero) + (setf emin + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add i4 3)) + ((1 *)) + z-%offset%)) + (setf oldemn + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add i4 4)) + ((1 *)) + z-%offset%))) + (t + (setf qmax + (max qmax + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add i4 + 1)) + ((1 *)) + z-%offset%))) + (setf emin + (min emin + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 + 1)) + ((1 *)) + z-%offset%))) + (setf oldemn + (min oldemn + (f2cl-lib:fref z-%data% + (i4) + ((1 *)) + z-%offset%))))))) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-mul 4 n0) + 1)) + ((1 *)) + z-%offset%) + emin) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-mul 4 n0)) + ((1 *)) + z-%offset%) + oldemn) + (setf i0 (f2cl-lib:int-add splt 1)))))))) + (setf info 2) + (go end_label) + label130)) + (setf info 3) + (go end_label) + label150 + (f2cl-lib:fdo (k 2 (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (setf (f2cl-lib:fref z-%data% (k) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 k) + 3)) + ((1 *)) + z-%offset%)))) + (multiple-value-bind (var-0 var-1 var-2 var-3) + (dlasrt "D" n z iinfo) + (declare (ignore var-0 var-1 var-2)) + (setf iinfo var-3)) + (setf e zero) + (f2cl-lib:fdo (k n (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k 1) nil) + (tagbody + (setf e (+ e (f2cl-lib:fref z-%data% (k) ((1 *)) z-%offset%))))) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add (f2cl-lib:int-mul 2 n) 1)) + ((1 *)) + z-%offset%) + trace$) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add (f2cl-lib:int-mul 2 n) 2)) + ((1 *)) + z-%offset%) + e) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add (f2cl-lib:int-mul 2 n) 3)) + ((1 *)) + z-%offset%) + (coerce (realpart iter) 'double-float)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add (f2cl-lib:int-mul 2 n) 4)) + ((1 *)) + z-%offset%) + (/ (coerce (realpart ndiv) 'double-float) + (coerce (realpart (expt n 2)) 'double-float))) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add (f2cl-lib:int-mul 2 n) 5)) + ((1 *)) + z-%offset%) + (/ (* hundrd nfail) + (coerce (realpart iter) 'double-float))) + (go end_label) + end_label + (return (values 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::dlasq2 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum (array double-float (*)) + fixnum) + :return-values '(nil nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlasq3 fortran-to-lisp::ilaenv + fortran-to-lisp::dlasrt fortran-to-lisp::xerbla + fortran-to-lisp::dlamch)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasq3 LAPACK} +\pagehead{dlasq3}{dlasq3} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((cbias 1.5) + (zero 0.0) + (qurtr 0.25) + (half 0.5) + (one 1.0) + (two 2.0) + (hundrd 100.0)) + (declare (type (double-float 1.5 1.5) cbias) + (type (double-float 0.0 0.0) zero) + (type (double-float 0.25 0.25) qurtr) + (type (double-float 0.5 0.5) half) + (type (double-float 1.0 1.0) one) + (type (double-float 2.0 2.0) two) + (type (double-float 100.0 100.0) hundrd)) + (let ((ttype 0) + (f2cl-lib:dmin1 zero) + (dmin2 zero) + (dn zero) + (dn1 zero) + (dn2 zero) + (tau zero)) + (declare (type (double-float) tau dn2 dn1 dn dmin2 f2cl-lib:dmin1) + (type fixnum ttype)) + (defun dlasq3 (i0 n0 z pp dmin sigma desig qmax nfail iter ndiv ieee) + (declare (type (member t nil) ieee) + (type (double-float) qmax desig sigma dmin) + (type (array double-float (*)) z) + (type fixnum ndiv iter nfail pp n0 i0)) + (f2cl-lib:with-multi-array-data + ((z double-float z-%data% z-%offset%)) + (prog ((eps 0.0) (s 0.0) (safmin 0.0) (temp 0.0) (tol 0.0) (tol2 0.0) + (ipn4 0) (j4 0) (n0in 0) (nn 0) (t$ 0.0)) + (declare (type (double-float) t$ eps s safmin temp tol tol2) + (type fixnum ipn4 j4 n0in nn)) + (setf n0in n0) + (setf eps (dlamch "Precision")) + (setf safmin (dlamch "Safe minimum")) + (setf tol (* eps hundrd)) + (setf tol2 (expt tol 2)) + label10 + (if (< n0 i0) (go end_label)) + (if (= n0 i0) (go label20)) + (setf nn (f2cl-lib:int-add (f2cl-lib:int-mul 4 n0) pp)) + (if (= n0 (f2cl-lib:int-add i0 1)) (go label40)) + (if + (and + (> + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 5)) + ((1 *)) + z-%offset%) + (* tol2 + (+ sigma + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 3)) + ((1 *)) + z-%offset%)))) + (> + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add nn (f2cl-lib:int-mul -1 2 pp)) + 4)) + ((1 *)) + z-%offset%) + (* tol2 + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 7)) + ((1 *)) + z-%offset%)))) + (go label30)) + label20 + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 n0) 3)) + ((1 *)) + z-%offset%) + (+ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add (f2cl-lib:int-mul 4 n0) + pp) + 3)) + ((1 *)) + z-%offset%) + sigma)) + (setf n0 (f2cl-lib:int-sub n0 1)) + (go label10) + label30 + (if + (and + (> + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 9)) + ((1 *)) + z-%offset%) + (* tol2 sigma)) + (> + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add nn (f2cl-lib:int-mul -1 2 pp)) + 8)) + ((1 *)) + z-%offset%) + (* tol2 + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 11)) + ((1 *)) + z-%offset%)))) + (go label50)) + label40 + (cond + ((> + (f2cl-lib:fref z + ((f2cl-lib:int-add nn (f2cl-lib:int-sub 3))) + ((1 *))) + (f2cl-lib:fref z + ((f2cl-lib:int-add nn (f2cl-lib:int-sub 7))) + ((1 *)))) + (setf s + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 3)) + ((1 *)) + z-%offset%)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 3)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 7)) + ((1 *)) + z-%offset%)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 7)) + ((1 *)) + z-%offset%) + s))) + (cond + ((> + (f2cl-lib:fref z + ((f2cl-lib:int-add nn (f2cl-lib:int-sub 5))) + ((1 *))) + (* + (f2cl-lib:fref z + ((f2cl-lib:int-add nn (f2cl-lib:int-sub 3))) + ((1 *))) + tol2)) + (setf t$ + (* half + (+ + (- + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 7)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 3)) + ((1 *)) + z-%offset%)) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 5)) + ((1 *)) + z-%offset%)))) + (setf s + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 3)) + ((1 *)) + z-%offset%) + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 5)) + ((1 *)) + z-%offset%) + t$))) + (cond + ((<= s t$) + (setf s + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 3)) + ((1 *)) + z-%offset%) + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 5)) + ((1 *)) + z-%offset%) + (* t$ (+ one (f2cl-lib:fsqrt (+ one (/ s t$))))))))) + (t + (setf s + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 3)) + ((1 *)) + z-%offset%) + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 5)) + ((1 *)) + z-%offset%) + (+ t$ + (* (f2cl-lib:fsqrt t$) + (f2cl-lib:fsqrt (+ t$ s))))))))) + (setf t$ + (+ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 7)) + ((1 *)) + z-%offset%) + (+ s + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 5)) + ((1 *)) + z-%offset%)))) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 3)) + ((1 *)) + z-%offset%) + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 3)) + ((1 *)) + z-%offset%) + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 7)) + ((1 *)) + z-%offset%) + t$))) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 7)) + ((1 *)) + z-%offset%) + t$))) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 n0) 7)) + ((1 *)) + z-%offset%) + (+ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 7)) + ((1 *)) + z-%offset%) + sigma)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 n0) 3)) + ((1 *)) + z-%offset%) + (+ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 3)) + ((1 *)) + z-%offset%) + sigma)) + (setf n0 (f2cl-lib:int-sub n0 2)) + (go label10) + label50 + (cond + ((or (<= dmin zero) (< n0 n0in)) + (cond + ((< + (* cbias + (f2cl-lib:fref z + ((f2cl-lib:int-add (f2cl-lib:int-mul 4 i0) + pp + (f2cl-lib:int-sub 3))) + ((1 *)))) + (f2cl-lib:fref z + ((f2cl-lib:int-add (f2cl-lib:int-mul 4 n0) + pp + (f2cl-lib:int-sub 3))) + ((1 *)))) + (setf ipn4 (f2cl-lib:int-mul 4 (f2cl-lib:int-add i0 n0))) + (f2cl-lib:fdo (j4 (f2cl-lib:int-mul 4 i0) + (f2cl-lib:int-add j4 4)) + ((> j4 + (f2cl-lib:int-mul 2 + (f2cl-lib:int-add i0 + n0 + (f2cl-lib:int-sub + 1)))) + nil) + (tagbody + (setf temp + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 3)) + ((1 *)) + z-%offset%)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 3)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub ipn4 j4 3)) + ((1 *)) + z-%offset%)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub ipn4 j4 3)) + ((1 *)) + z-%offset%) + temp) + (setf temp + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub ipn4 j4 2)) + ((1 *)) + z-%offset%)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub ipn4 j4 2)) + ((1 *)) + z-%offset%) + temp) + (setf temp + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 1)) + ((1 *)) + z-%offset%)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 1)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub ipn4 j4 5)) + ((1 *)) + z-%offset%)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub ipn4 j4 5)) + ((1 *)) + z-%offset%) + temp) + (setf temp + (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%)) + (setf (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub ipn4 j4 4)) + ((1 *)) + z-%offset%)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub ipn4 j4 4)) + ((1 *)) + z-%offset%) + temp))) + (cond + ((<= (f2cl-lib:int-add n0 (f2cl-lib:int-sub i0)) 4) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add + (f2cl-lib:int-mul 4 n0) + pp) + 1)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add + (f2cl-lib:int-mul 4 i0) + pp) + 1)) + ((1 *)) + z-%offset%)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-mul 4 n0) + pp)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-mul 4 i0) + pp)) + ((1 *)) + z-%offset%)))) + (setf dmin2 + (min dmin2 + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add + (f2cl-lib:int-mul 4 n0) + pp) + 1)) + ((1 *)) + z-%offset%))) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add + (f2cl-lib:int-mul 4 n0) + pp) + 1)) + ((1 *)) + z-%offset%) + (min + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add + (f2cl-lib:int-mul 4 n0) + pp) + 1)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add + (f2cl-lib:int-mul 4 i0) + pp) + 1)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-mul 4 i0) + pp + 3)) + ((1 *)) + z-%offset%))) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 n0) + pp)) + ((1 *)) + z-%offset%) + (min + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-mul 4 n0) + pp)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-mul 4 i0) + pp)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub + (f2cl-lib:int-mul 4 i0) + pp) + 4)) + ((1 *)) + z-%offset%))) + (setf qmax + (max qmax + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add + (f2cl-lib:int-mul 4 i0) + pp) + 3)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-mul 4 i0) + pp + 1)) + ((1 *)) + z-%offset%))) + (setf dmin (- zero)))))) + (cond + ((or (< dmin zero) + (< (* safmin qmax) + (min + (f2cl-lib:fref z + ((f2cl-lib:int-add (f2cl-lib:int-mul 4 n0) + pp + (f2cl-lib:int-sub 1))) + ((1 *))) + (f2cl-lib:fref z + ((f2cl-lib:int-add (f2cl-lib:int-mul 4 n0) + pp + (f2cl-lib:int-sub 9))) + ((1 *))) + (+ dmin2 + (f2cl-lib:fref z + ((f2cl-lib:int-add + (f2cl-lib:int-mul 4 n0) + (f2cl-lib:int-sub pp))) + ((1 *))))))) + (tagbody + (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) + (dlasq4 i0 n0 z pp n0in dmin f2cl-lib:dmin1 dmin2 dn dn1 dn2 + tau ttype) + (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 tau var-11) + (setf ttype var-12)) + label80 + (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) + (dlasq5 i0 n0 z pp tau dmin f2cl-lib:dmin1 dmin2 dn dn1 dn2 + ieee) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-6 var-11)) + (setf dmin var-5) + (setf dmin2 var-7) + (setf dn var-8) + (setf dn1 var-9) + (setf dn2 var-10)) + (setf ndiv + (f2cl-lib:int-add ndiv + (f2cl-lib:int-add + (f2cl-lib:int-sub n0 i0) + 2))) + (setf iter (f2cl-lib:int-add iter 1)) + (cond + ((and (>= dmin zero) (> f2cl-lib:dmin1 zero)) + (go label100)) + ((and (< dmin zero) + (> f2cl-lib:dmin1 zero) + (< + (f2cl-lib:fref z + ((f2cl-lib:int-add + (f2cl-lib:int-mul 4 + (f2cl-lib:int-add n0 + (f2cl-lib:int-sub + 1))) + (f2cl-lib:int-sub pp))) + ((1 *))) + (* tol (+ sigma dn1))) + (< (abs dn) (* tol sigma))) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub + (f2cl-lib:int-mul 4 + (f2cl-lib:int-sub + n0 + 1)) + pp) + 2)) + ((1 *)) + z-%offset%) + zero) + (setf dmin zero) + (go label100)) + ((< dmin zero) + (setf nfail (f2cl-lib:int-add nfail 1)) + (cond + ((< ttype (f2cl-lib:int-sub 22)) + (setf tau zero)) + ((> f2cl-lib:dmin1 zero) + (setf tau (* (+ tau dmin) (- one (* two eps)))) + (setf ttype (f2cl-lib:int-sub ttype 11))) + (t + (setf tau (* qurtr tau)) + (setf ttype (f2cl-lib:int-sub ttype 12)))) + (go label80)) + ((/= dmin dmin) + (setf tau zero) + (go label80)) + (t + (go label90)))))) + label90 + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9) + (dlasq6 i0 n0 z pp dmin f2cl-lib:dmin1 dmin2 dn dn1 dn2) + (declare (ignore var-0 var-1 var-2 var-3 var-5)) + (setf dmin var-4) + (setf dmin2 var-6) + (setf dn var-7) + (setf dn1 var-8) + (setf dn2 var-9)) + (setf ndiv + (f2cl-lib:int-add ndiv + (f2cl-lib:int-add (f2cl-lib:int-sub n0 i0) + 2))) + (setf iter (f2cl-lib:int-add iter 1)) + (setf tau zero) + label100 + (cond + ((< tau sigma) + (setf desig (+ desig tau)) + (setf t$ (+ sigma desig)) + (setf desig (- desig (- t$ sigma)))) + (t + (setf t$ (+ sigma tau)) + (setf desig (+ (- sigma (- t$ tau)) desig)))) + (setf sigma t$) + end_label + (return + (values nil + n0 + nil + nil + dmin + sigma + desig + qmax + nfail + iter + ndiv + 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::dlasq3 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (array double-float (*)) fixnum + (double-float) (double-float) (double-float) + (double-float) fixnum + fixnum fixnum + (member t nil)) + :return-values '(nil fortran-to-lisp::n0 nil nil + fortran-to-lisp::dmin fortran-to-lisp::sigma + fortran-to-lisp::desig fortran-to-lisp::qmax + fortran-to-lisp::nfail fortran-to-lisp::iter + fortran-to-lisp::ndiv nil) + :calls '(fortran-to-lisp::dlasq6 fortran-to-lisp::dlasq5 + fortran-to-lisp::dlasq4 fortran-to-lisp::dlamch)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasq4 LAPACK} +\pagehead{dlasq4}{dlasq4} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((cnst1 0.563) + (cnst2 1.01) + (cnst3 1.05) + (qurtr 0.25) + (third$ 0.333) + (half 0.5) + (zero 0.0) + (one 1.0) + (two 2.0) + (hundrd 100.0)) + (declare (type (double-float 0.563 0.563) cnst1) + (type (double-float 1.01 1.01) cnst2) + (type (double-float 1.05 1.05) cnst3) + (type (double-float 0.25 0.25) qurtr) + (type (double-float 0.333 0.333) third$) + (type (double-float 0.5 0.5) half) + (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 100.0 100.0) hundrd)) + (let ((g zero)) + (declare (type (double-float) g)) + (defun dlasq4 + (i0 n0 z pp n0in dmin f2cl-lib:dmin1 dmin2 dn dn1 dn2 tau ttype) + (declare (type (double-float) tau dn2 dn1 dn dmin2 f2cl-lib:dmin1 dmin) + (type (array double-float (*)) z) + (type fixnum ttype n0in pp n0 i0)) + (f2cl-lib:with-multi-array-data + ((z double-float z-%data% z-%offset%)) + (prog ((a2 0.0) (b1 0.0) (b2 0.0) (gam 0.0) (gap1 0.0) (gap2 0.0) + (s 0.0) (i4 0) (nn 0) (np 0) (sqrt$ 0.0f0)) + (declare (type (single-float) sqrt$) + (type (double-float) a2 b1 b2 gam gap1 gap2 s) + (type fixnum i4 nn np)) + (cond + ((<= dmin zero) + (setf tau (- dmin)) + (setf ttype -1) + (go end_label))) + (setf nn (f2cl-lib:int-add (f2cl-lib:int-mul 4 n0) pp)) + (cond + ((= n0in n0) + (cond + ((or (= dmin dn) (= dmin dn1)) + (setf b1 + (* + (f2cl-lib:fsqrt + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 3)) + ((1 *)) + z-%offset%)) + (f2cl-lib:fsqrt + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 5)) + ((1 *)) + z-%offset%)))) + (setf b2 + (* + (f2cl-lib:fsqrt + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 7)) + ((1 *)) + z-%offset%)) + (f2cl-lib:fsqrt + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 9)) + ((1 *)) + z-%offset%)))) + (setf a2 + (+ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 7)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 5)) + ((1 *)) + z-%offset%))) + (cond + ((and (= dmin dn) (= f2cl-lib:dmin1 dn1)) + (setf gap2 (- dmin2 a2 (* dmin2 qurtr))) + (cond + ((and (> gap2 zero) (> gap2 b2)) + (setf gap1 (- a2 dn (* (/ b2 gap2) b2)))) + (t + (setf gap1 (- a2 dn (+ b1 b2))))) + (cond + ((and (> gap1 zero) (> gap1 b1)) + (setf s (max (- dn (* (/ b1 gap1) b1)) (* half dmin))) + (setf ttype -2)) + (t + (setf s zero) + (if (> dn b1) (setf s (- dn b1))) + (if (> a2 (+ b1 b2)) (setf s (min s (- a2 (+ b1 b2))))) + (setf s (max s (* third$ dmin))) + (setf ttype -3)))) + (t + (tagbody + (setf ttype -4) + (setf s (* qurtr dmin)) + (cond + ((= dmin dn) + (setf gam dn) + (setf a2 zero) + (if + (> + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 5)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 7)) + ((1 *)) + z-%offset%)) + (go end_label)) + (setf b2 + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 5)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 7)) + ((1 *)) + z-%offset%))) + (setf np (f2cl-lib:int-sub nn 9))) + (t + (setf np (f2cl-lib:int-sub nn (f2cl-lib:int-mul 2 pp))) + (setf b2 + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub np 2)) + ((1 *)) + z-%offset%)) + (setf gam dn1) + (if + (> + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub np 4)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub np 2)) + ((1 *)) + z-%offset%)) + (go end_label)) + (setf a2 + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub np 4)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub np 2)) + ((1 *)) + z-%offset%))) + (if + (> + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 9)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 11)) + ((1 *)) + z-%offset%)) + (go end_label)) + (setf b2 + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 9)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 11)) + ((1 *)) + z-%offset%))) + (setf np (f2cl-lib:int-sub nn 13)))) + (setf a2 (+ a2 b2)) + (f2cl-lib:fdo (i4 np + (f2cl-lib:int-add i4 (f2cl-lib:int-sub 4))) + ((> i4 + (f2cl-lib:int-add + (f2cl-lib:int-mul 4 i0) + (f2cl-lib:int-sub 1) + pp)) + nil) + (tagbody + (if (= b2 zero) (go label20)) + (setf b1 b2) + (if + (> (f2cl-lib:fref z-%data% (i4) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 2)) + ((1 *)) + z-%offset%)) + (go end_label)) + (setf b2 + (* b2 + (/ + (f2cl-lib:fref z-%data% + (i4) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 2)) + ((1 *)) + z-%offset%)))) + (setf a2 (+ a2 b2)) + (if (or (< (* hundrd (max b2 b1)) a2) (< cnst1 a2)) + (go label20)))) + label20 + (setf a2 (* cnst3 a2)) + (if (< a2 cnst1) + (setf s + (/ (* gam (- one (f2cl-lib:fsqrt a2))) + (+ one a2)))))))) + ((= dmin dn2) + (setf ttype -5) + (setf s (* qurtr dmin)) + (setf np (f2cl-lib:int-sub nn (f2cl-lib:int-mul 2 pp))) + (setf b1 + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub np 2)) + ((1 *)) + z-%offset%)) + (setf b2 + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub np 6)) + ((1 *)) + z-%offset%)) + (setf gam dn2) + (if + (or + (> + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub np 8)) + ((1 *)) + z-%offset%) + b2) + (> + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub np 4)) + ((1 *)) + z-%offset%) + b1)) + (go end_label)) + (setf a2 + (* + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub np 8)) + ((1 *)) + z-%offset%) + b2) + (+ one + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub np 4)) + ((1 *)) + z-%offset%) + b1)))) + (cond + ((> (f2cl-lib:int-add n0 (f2cl-lib:int-sub i0)) 2) + (tagbody + (setf b2 + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 13)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 15)) + ((1 *)) + z-%offset%))) + (setf a2 (+ a2 b2)) + (f2cl-lib:fdo (i4 + (f2cl-lib:int-add nn (f2cl-lib:int-sub 17)) + (f2cl-lib:int-add i4 (f2cl-lib:int-sub 4))) + ((> i4 + (f2cl-lib:int-add + (f2cl-lib:int-mul 4 i0) + (f2cl-lib:int-sub 1) + pp)) + nil) + (tagbody + (if (= b2 zero) (go label40)) + (setf b1 b2) + (if + (> (f2cl-lib:fref z-%data% (i4) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 2)) + ((1 *)) + z-%offset%)) + (go end_label)) + (setf b2 + (* b2 + (/ + (f2cl-lib:fref z-%data% + (i4) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 2)) + ((1 *)) + z-%offset%)))) + (setf a2 (+ a2 b2)) + (if (or (< (* hundrd (max b2 b1)) a2) (< cnst1 a2)) + (go label40)))) + label40 + (setf a2 (* cnst3 a2))))) + (if (< a2 cnst1) + (setf s + (/ (* gam (- one (f2cl-lib:fsqrt a2))) + (+ one a2))))) + (t + (cond + ((= ttype (f2cl-lib:int-sub 6)) + (setf g (+ g (* third$ (- one g))))) + ((= ttype (f2cl-lib:int-sub 18)) + (setf g (* qurtr third$))) + (t + (setf g qurtr))) + (setf s (* g dmin)) + (setf ttype -6)))) + ((= n0in (f2cl-lib:int-add n0 1)) + (cond + ((and (= f2cl-lib:dmin1 dn1) (= dmin2 dn2)) + (tagbody + (setf ttype -7) + (setf s (* third$ f2cl-lib:dmin1)) + (if + (> + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 5)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 7)) + ((1 *)) + z-%offset%)) + (go end_label)) + (setf b1 + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 5)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 7)) + ((1 *)) + z-%offset%))) + (setf b2 b1) + (if (= b2 zero) (go label60)) + (f2cl-lib:fdo (i4 + (f2cl-lib:int-add (f2cl-lib:int-mul 4 n0) + (f2cl-lib:int-sub 9) + pp) + (f2cl-lib:int-add i4 (f2cl-lib:int-sub 4))) + ((> i4 + (f2cl-lib:int-add (f2cl-lib:int-mul 4 i0) + (f2cl-lib:int-sub 1) + pp)) + nil) + (tagbody + (setf a2 b1) + (if + (> (f2cl-lib:fref z-%data% (i4) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 2)) + ((1 *)) + z-%offset%)) + (go end_label)) + (setf b1 + (* b1 + (/ + (f2cl-lib:fref z-%data% + (i4) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 2)) + ((1 *)) + z-%offset%)))) + (setf b2 (+ b2 b1)) + (if (< (* hundrd (max b1 a2)) b2) (go label60)))) + label60 + (setf b2 (f2cl-lib:fsqrt (* cnst3 b2))) + (setf a2 (/ f2cl-lib:dmin1 (+ one (expt b2 2)))) + (setf gap2 (- (* half dmin2) a2)) + (cond + ((and (> gap2 zero) (> gap2 (* b2 a2))) + (setf s + (max s + (* a2 + (+ one (* (- cnst2) a2 (/ b2 gap2) b2)))))) + (t + (setf s (max s (* a2 (- one (* cnst2 b2))))) + (setf ttype -8))))) + (t + (setf s (* qurtr f2cl-lib:dmin1)) + (if (= f2cl-lib:dmin1 dn1) (setf s (* half f2cl-lib:dmin1))) + (setf ttype -9)))) + ((= n0in (f2cl-lib:int-add n0 2)) + (cond + ((and (= dmin2 dn2) + (< + (* two + (f2cl-lib:fref z + ((f2cl-lib:int-add nn + (f2cl-lib:int-sub + 5))) + ((1 *)))) + (f2cl-lib:fref z + ((f2cl-lib:int-add nn + (f2cl-lib:int-sub 7))) + ((1 *))))) + (tagbody + (setf ttype -10) + (setf s (* third$ dmin2)) + (if + (> + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 5)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 7)) + ((1 *)) + z-%offset%)) + (go end_label)) + (setf b1 + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 5)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 7)) + ((1 *)) + z-%offset%))) + (setf b2 b1) + (if (= b2 zero) (go label80)) + (f2cl-lib:fdo (i4 + (f2cl-lib:int-add (f2cl-lib:int-mul 4 n0) + (f2cl-lib:int-sub 9) + pp) + (f2cl-lib:int-add i4 (f2cl-lib:int-sub 4))) + ((> i4 + (f2cl-lib:int-add (f2cl-lib:int-mul 4 i0) + (f2cl-lib:int-sub 1) + pp)) + nil) + (tagbody + (if + (> (f2cl-lib:fref z-%data% (i4) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 2)) + ((1 *)) + z-%offset%)) + (go end_label)) + (setf b1 + (* b1 + (/ + (f2cl-lib:fref z-%data% + (i4) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub i4 2)) + ((1 *)) + z-%offset%)))) + (setf b2 (+ b2 b1)) + (if (< (* hundrd b1) b2) (go label80)))) + label80 + (setf b2 (f2cl-lib:fsqrt (* cnst3 b2))) + (setf a2 (/ dmin2 (+ one (expt b2 2)))) + (setf gap2 + (- + (+ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 7)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 9)) + ((1 *)) + z-%offset%)) + (* + (f2cl-lib:fsqrt + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 11)) + ((1 *)) + z-%offset%)) + (f2cl-lib:fsqrt + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub nn 9)) + ((1 *)) + z-%offset%))) + a2)) + (cond + ((and (> gap2 zero) (> gap2 (* b2 a2))) + (setf s + (max s + (* a2 + (+ one (* (- cnst2) a2 (/ b2 gap2) b2)))))) + (t + (setf s (max s (* a2 (- one (* cnst2 b2))))))))) + (t + (setf s (* qurtr dmin2)) + (setf ttype -11)))) + ((> n0in (f2cl-lib:int-add n0 2)) + (setf s zero) + (setf ttype -12))) + (setf tau s) + end_label + (return + (values nil nil nil nil nil nil nil nil nil nil nil tau ttype))))))) + +(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::dlasq4 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (array double-float (*)) fixnum + fixnum (double-float) + (double-float) (double-float) (double-float) + (double-float) (double-float) (double-float) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::tau fortran-to-lisp::ttype) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasq5 LAPACK} +\pagehead{dlasq5}{dlasq5} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dlasq5 (i0 n0 z pp tau dmin f2cl-lib:dmin1 dmin2 dn dnm1 dnm2 ieee) + (declare (type (member t nil) ieee) + (type (double-float) dnm2 dnm1 dn dmin2 f2cl-lib:dmin1 dmin tau) + (type (array double-float (*)) z) + (type fixnum pp n0 i0)) + (f2cl-lib:with-multi-array-data + ((z double-float z-%data% z-%offset%)) + (prog ((d 0.0) (emin 0.0) (temp 0.0) (j4 0) (j4p2 0)) + (declare (type (double-float) d emin temp) + (type fixnum j4 j4p2)) + (if (<= (f2cl-lib:int-sub n0 i0 1) 0) (go end_label)) + (setf j4 + (f2cl-lib:int-sub (f2cl-lib:int-add (f2cl-lib:int-mul 4 i0) pp) + 3)) + (setf emin + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4 4)) + ((1 *)) + z-%offset%)) + (setf d (- (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) tau)) + (setf dmin d) + (setf f2cl-lib:dmin1 + (- (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%))) + (cond + (ieee + (cond + ((= pp 0) + (f2cl-lib:fdo (j4 (f2cl-lib:int-mul 4 i0) (f2cl-lib:int-add j4 4)) + ((> j4 + (f2cl-lib:int-mul 4 + (f2cl-lib:int-add n0 + (f2cl-lib:int-sub + 3)))) + nil) + (tagbody + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%) + (+ d + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 1)) + ((1 *)) + z-%offset%))) + (setf temp + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4 1)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%))) + (setf d (- (* d temp) tau)) + (setf dmin (min dmin d)) + (setf (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 1)) + ((1 *)) + z-%offset%) + temp)) + (setf emin + (min (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) + emin))))) + (t + (f2cl-lib:fdo (j4 (f2cl-lib:int-mul 4 i0) (f2cl-lib:int-add j4 4)) + ((> j4 + (f2cl-lib:int-mul 4 + (f2cl-lib:int-add n0 + (f2cl-lib:int-sub + 3)))) + nil) + (tagbody + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 3)) + ((1 *)) + z-%offset%) + (+ d + (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%))) + (setf temp + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4 2)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 3)) + ((1 *)) + z-%offset%))) + (setf d (- (* d temp) tau)) + (setf dmin (min dmin d)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 1)) + ((1 *)) + z-%offset%) + (* (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) + temp)) + (setf emin + (min + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 1)) + ((1 *)) + z-%offset%) + emin)))))) + (setf dnm2 d) + (setf dmin2 dmin) + (setf j4 + (f2cl-lib:int-sub + (f2cl-lib:int-mul 4 (f2cl-lib:int-sub n0 2)) + pp)) + (setf j4p2 + (f2cl-lib:int-sub + (f2cl-lib:int-add j4 (f2cl-lib:int-mul 2 pp)) + 1)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%) + (+ dnm2 (f2cl-lib:fref z-%data% (j4p2) ((1 *)) z-%offset%))) + (setf (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4p2 2)) + ((1 *)) + z-%offset%) + (/ (f2cl-lib:fref z-%data% (j4p2) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%)))) + (setf dnm1 + (- + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4p2 2)) + ((1 *)) + z-%offset%) + (/ dnm2 + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%))) + tau)) + (setf dmin (min dmin dnm1)) + (setf f2cl-lib:dmin1 dmin) + (setf j4 (f2cl-lib:int-add j4 4)) + (setf j4p2 + (f2cl-lib:int-sub + (f2cl-lib:int-add j4 (f2cl-lib:int-mul 2 pp)) + 1)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%) + (+ dnm1 (f2cl-lib:fref z-%data% (j4p2) ((1 *)) z-%offset%))) + (setf (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4p2 2)) + ((1 *)) + z-%offset%) + (/ (f2cl-lib:fref z-%data% (j4p2) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%)))) + (setf dn + (- + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4p2 2)) + ((1 *)) + z-%offset%) + (/ dnm1 + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%))) + tau)) + (setf dmin (min dmin dn))) + (t + (cond + ((= pp 0) + (f2cl-lib:fdo (j4 (f2cl-lib:int-mul 4 i0) (f2cl-lib:int-add j4 4)) + ((> j4 + (f2cl-lib:int-mul 4 + (f2cl-lib:int-add n0 + (f2cl-lib:int-sub + 3)))) + nil) + (tagbody + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%) + (+ d + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 1)) + ((1 *)) + z-%offset%))) + (cond + ((< d zero) + (go end_label)) + (t + (setf (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4 1)) + ((1 *)) + z-%offset%) + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 1)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%)))) + (setf d + (- + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4 1)) + ((1 *)) + z-%offset%) + (/ d + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%))) + tau)))) + (setf dmin (min dmin d)) + (setf emin + (min emin + (f2cl-lib:fref z-%data% + (j4) + ((1 *)) + z-%offset%)))))) + (t + (f2cl-lib:fdo (j4 (f2cl-lib:int-mul 4 i0) (f2cl-lib:int-add j4 4)) + ((> j4 + (f2cl-lib:int-mul 4 + (f2cl-lib:int-add n0 + (f2cl-lib:int-sub + 3)))) + nil) + (tagbody + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 3)) + ((1 *)) + z-%offset%) + (+ d + (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%))) + (cond + ((< d zero) + (go end_label)) + (t + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 1)) + ((1 *)) + z-%offset%) + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4 2)) + ((1 *)) + z-%offset%) + (/ + (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 3)) + ((1 *)) + z-%offset%)))) + (setf d + (- + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4 2)) + ((1 *)) + z-%offset%) + (/ d + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 3)) + ((1 *)) + z-%offset%))) + tau)))) + (setf dmin (min dmin d)) + (setf emin + (min emin + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 1)) + ((1 *)) + z-%offset%))))))) + (setf dnm2 d) + (setf dmin2 dmin) + (setf j4 + (f2cl-lib:int-sub + (f2cl-lib:int-mul 4 (f2cl-lib:int-sub n0 2)) + pp)) + (setf j4p2 + (f2cl-lib:int-sub + (f2cl-lib:int-add j4 (f2cl-lib:int-mul 2 pp)) + 1)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%) + (+ dnm2 (f2cl-lib:fref z-%data% (j4p2) ((1 *)) z-%offset%))) + (cond + ((< dnm2 zero) + (go end_label)) + (t + (setf (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4p2 2)) + ((1 *)) + z-%offset%) + (/ (f2cl-lib:fref z-%data% (j4p2) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%)))) + (setf dnm1 + (- + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4p2 2)) + ((1 *)) + z-%offset%) + (/ dnm2 + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%))) + tau)))) + (setf dmin (min dmin dnm1)) + (setf f2cl-lib:dmin1 dmin) + (setf j4 (f2cl-lib:int-add j4 4)) + (setf j4p2 + (f2cl-lib:int-sub + (f2cl-lib:int-add j4 (f2cl-lib:int-mul 2 pp)) + 1)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%) + (+ dnm1 (f2cl-lib:fref z-%data% (j4p2) ((1 *)) z-%offset%))) + (cond + ((< dnm1 zero) + (go end_label)) + (t + (setf (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4p2 2)) + ((1 *)) + z-%offset%) + (/ (f2cl-lib:fref z-%data% (j4p2) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%)))) + (setf dn + (- + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4p2 2)) + ((1 *)) + z-%offset%) + (/ dnm1 + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%))) + tau)))) + (setf dmin (min dmin dn)))) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4 2)) + ((1 *)) + z-%offset%) + dn) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 n0) pp)) + ((1 *)) + z-%offset%) + emin) + end_label + (return + (values nil + nil + nil + nil + nil + dmin + f2cl-lib:dmin1 + dmin2 + dn + dnm1 + dnm2 + 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::dlasq5 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (array double-float (*)) fixnum + (double-float) (double-float) (double-float) + (double-float) (double-float) (double-float) + (double-float) (member t nil)) + :return-values '(nil nil nil nil nil fortran-to-lisp::dmin + fortran-to-lisp::dmin1 fortran-to-lisp::dmin2 + fortran-to-lisp::dn fortran-to-lisp::dnm1 + fortran-to-lisp::dnm2 nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasq6 LAPACK} +\pagehead{dlasq6}{dlasq6} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dlasq6 (i0 n0 z pp dmin f2cl-lib:dmin1 dmin2 dn dnm1 dnm2) + (declare (type (double-float) dnm2 dnm1 dn dmin2 f2cl-lib:dmin1 dmin) + (type (array double-float (*)) z) + (type fixnum pp n0 i0)) + (f2cl-lib:with-multi-array-data + ((z double-float z-%data% z-%offset%)) + (prog ((d 0.0) (emin 0.0) (safmin 0.0) (temp 0.0) (j4 0) (j4p2 0)) + (declare (type (double-float) d emin safmin temp) + (type fixnum j4 j4p2)) + (if (<= (f2cl-lib:int-sub n0 i0 1) 0) (go end_label)) + (setf safmin (dlamch "Safe minimum")) + (setf j4 + (f2cl-lib:int-sub (f2cl-lib:int-add (f2cl-lib:int-mul 4 i0) pp) + 3)) + (setf emin + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4 4)) + ((1 *)) + z-%offset%)) + (setf d (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%)) + (setf dmin d) + (cond + ((= pp 0) + (f2cl-lib:fdo (j4 (f2cl-lib:int-mul 4 i0) (f2cl-lib:int-add j4 4)) + ((> j4 + (f2cl-lib:int-mul 4 + (f2cl-lib:int-add n0 + (f2cl-lib:int-sub + 3)))) + nil) + (tagbody + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%) + (+ d + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 1)) + ((1 *)) + z-%offset%))) + (cond + ((= + (f2cl-lib:fref z + ((f2cl-lib:int-add j4 (f2cl-lib:int-sub 2))) + ((1 *))) + zero) + (setf (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) zero) + (setf d + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4 1)) + ((1 *)) + z-%offset%)) + (setf dmin d) + (setf emin zero)) + ((and + (< + (* safmin + (f2cl-lib:fref z ((f2cl-lib:int-add j4 1)) ((1 *)))) + (f2cl-lib:fref z + ((f2cl-lib:int-add j4 (f2cl-lib:int-sub 2))) + ((1 *)))) + (< + (* safmin + (f2cl-lib:fref z + ((f2cl-lib:int-add j4 + (f2cl-lib:int-sub 2))) + ((1 *)))) + (f2cl-lib:fref z ((f2cl-lib:int-add j4 1)) ((1 *))))) + (setf temp + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4 1)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%))) + (setf (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 1)) + ((1 *)) + z-%offset%) + temp)) + (setf d (* d temp))) + (t + (setf (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4 1)) + ((1 *)) + z-%offset%) + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 1)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%)))) + (setf d + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4 1)) + ((1 *)) + z-%offset%) + (/ d + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%)))))) + (setf dmin (min dmin d)) + (setf emin + (min emin + (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%)))))) + (t + (f2cl-lib:fdo (j4 (f2cl-lib:int-mul 4 i0) (f2cl-lib:int-add j4 4)) + ((> j4 + (f2cl-lib:int-mul 4 + (f2cl-lib:int-add n0 + (f2cl-lib:int-sub + 3)))) + nil) + (tagbody + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 3)) + ((1 *)) + z-%offset%) + (+ d (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%))) + (cond + ((= + (f2cl-lib:fref z + ((f2cl-lib:int-add j4 (f2cl-lib:int-sub 3))) + ((1 *))) + zero) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 1)) + ((1 *)) + z-%offset%) + zero) + (setf d + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4 2)) + ((1 *)) + z-%offset%)) + (setf dmin d) + (setf emin zero)) + ((and + (< + (* safmin + (f2cl-lib:fref z ((f2cl-lib:int-add j4 2)) ((1 *)))) + (f2cl-lib:fref z + ((f2cl-lib:int-add j4 (f2cl-lib:int-sub 3))) + ((1 *)))) + (< + (* safmin + (f2cl-lib:fref z + ((f2cl-lib:int-add j4 + (f2cl-lib:int-sub 3))) + ((1 *)))) + (f2cl-lib:fref z ((f2cl-lib:int-add j4 2)) ((1 *))))) + (setf temp + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4 2)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 3)) + ((1 *)) + z-%offset%))) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 1)) + ((1 *)) + z-%offset%) + (* (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) + temp)) + (setf d (* d temp))) + (t + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 1)) + ((1 *)) + z-%offset%) + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4 2)) + ((1 *)) + z-%offset%) + (/ (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 3)) + ((1 *)) + z-%offset%)))) + (setf d + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4 2)) + ((1 *)) + z-%offset%) + (/ d + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 3)) + ((1 *)) + z-%offset%)))))) + (setf dmin (min dmin d)) + (setf emin + (min emin + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 1)) + ((1 *)) + z-%offset%))))))) + (setf dnm2 d) + (setf dmin2 dmin) + (setf j4 + (f2cl-lib:int-sub (f2cl-lib:int-mul 4 (f2cl-lib:int-sub n0 2)) + pp)) + (setf j4p2 + (f2cl-lib:int-sub (f2cl-lib:int-add j4 (f2cl-lib:int-mul 2 pp)) + 1)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%) + (+ dnm2 (f2cl-lib:fref z-%data% (j4p2) ((1 *)) z-%offset%))) + (cond + ((= + (f2cl-lib:fref z + ((f2cl-lib:int-add j4 (f2cl-lib:int-sub 2))) + ((1 *))) + zero) + (setf (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) zero) + (setf dnm1 + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4p2 2)) + ((1 *)) + z-%offset%)) + (setf dmin dnm1) + (setf emin zero)) + ((and + (< (* safmin (f2cl-lib:fref z ((f2cl-lib:int-add j4p2 2)) ((1 *)))) + (f2cl-lib:fref z + ((f2cl-lib:int-add j4 (f2cl-lib:int-sub 2))) + ((1 *)))) + (< + (* safmin + (f2cl-lib:fref z + ((f2cl-lib:int-add j4 (f2cl-lib:int-sub 2))) + ((1 *)))) + (f2cl-lib:fref z ((f2cl-lib:int-add j4p2 2)) ((1 *))))) + (setf temp + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4p2 2)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%))) + (setf (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) + (* (f2cl-lib:fref z-%data% (j4p2) ((1 *)) z-%offset%) temp)) + (setf dnm1 (* dnm2 temp))) + (t + (setf (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4p2 2)) + ((1 *)) + z-%offset%) + (/ (f2cl-lib:fref z-%data% (j4p2) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%)))) + (setf dnm1 + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4p2 2)) + ((1 *)) + z-%offset%) + (/ dnm2 + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%)))))) + (setf dmin (min dmin dnm1)) + (setf f2cl-lib:dmin1 dmin) + (setf j4 (f2cl-lib:int-add j4 4)) + (setf j4p2 + (f2cl-lib:int-sub (f2cl-lib:int-add j4 (f2cl-lib:int-mul 2 pp)) + 1)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%) + (+ dnm1 (f2cl-lib:fref z-%data% (j4p2) ((1 *)) z-%offset%))) + (cond + ((= + (f2cl-lib:fref z + ((f2cl-lib:int-add j4 (f2cl-lib:int-sub 2))) + ((1 *))) + zero) + (setf (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) zero) + (setf dn + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4p2 2)) + ((1 *)) + z-%offset%)) + (setf dmin dn) + (setf emin zero)) + ((and + (< (* safmin (f2cl-lib:fref z ((f2cl-lib:int-add j4p2 2)) ((1 *)))) + (f2cl-lib:fref z + ((f2cl-lib:int-add j4 (f2cl-lib:int-sub 2))) + ((1 *)))) + (< + (* safmin + (f2cl-lib:fref z + ((f2cl-lib:int-add j4 (f2cl-lib:int-sub 2))) + ((1 *)))) + (f2cl-lib:fref z ((f2cl-lib:int-add j4p2 2)) ((1 *))))) + (setf temp + (/ + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4p2 2)) + ((1 *)) + z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%))) + (setf (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) + (* (f2cl-lib:fref z-%data% (j4p2) ((1 *)) z-%offset%) temp)) + (setf dn (* dnm1 temp))) + (t + (setf (f2cl-lib:fref z-%data% (j4) ((1 *)) z-%offset%) + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4p2 2)) + ((1 *)) + z-%offset%) + (/ (f2cl-lib:fref z-%data% (j4p2) ((1 *)) z-%offset%) + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%)))) + (setf dn + (* + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4p2 2)) + ((1 *)) + z-%offset%) + (/ dnm1 + (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub j4 2)) + ((1 *)) + z-%offset%)))))) + (setf dmin (min dmin dn)) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-add j4 2)) + ((1 *)) + z-%offset%) + dn) + (setf (f2cl-lib:fref z-%data% + ((f2cl-lib:int-sub (f2cl-lib:int-mul 4 n0) pp)) + ((1 *)) + z-%offset%) + emin) + end_label + (return + (values nil nil nil nil dmin f2cl-lib:dmin1 dmin2 dn dnm1 dnm2)))))) + +(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::dlasq6 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + (array double-float (*)) fixnum + (double-float) (double-float) (double-float) + (double-float) (double-float) (double-float)) + :return-values '(nil nil nil nil fortran-to-lisp::dmin + fortran-to-lisp::dmin1 fortran-to-lisp::dmin2 + fortran-to-lisp::dn fortran-to-lisp::dnm1 + fortran-to-lisp::dnm2) + :calls '(fortran-to-lisp::dlamch)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasr LAPACK} +\pagehead{dlasr}{dlasr} +%\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 dlasr (side pivot direct m n c s a lda) + (declare (type (array double-float (*)) a s c) + (type fixnum lda n m) + (type (simple-array character (*)) direct pivot side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (pivot character pivot-%data% pivot-%offset%) + (direct character direct-%data% direct-%offset%) + (c double-float c-%data% c-%offset%) + (s double-float s-%data% s-%offset%) + (a double-float a-%data% a-%offset%)) + (prog ((ctemp 0.0) (stemp 0.0) (temp 0.0) (i 0) (info 0) (j 0)) + (declare (type (double-float) ctemp stemp temp) + (type fixnum i info j)) + (setf info 0) + (cond + ((not (or (lsame side "L") (lsame side "R"))) + (setf info 1)) + ((not (or (lsame pivot "V") (lsame pivot "T") (lsame pivot "B"))) + (setf info 2)) + ((not (or (lsame direct "F") (lsame direct "B"))) + (setf info 3)) + ((< m 0) + (setf info 4)) + ((< n 0) + (setf info 5)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "DLASR " info) + (go end_label))) + (if (or (= m 0) (= n 0)) (go end_label)) + (cond + ((lsame side "L") + (cond + ((lsame pivot "V") + (cond + ((lsame direct "F") + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j (f2cl-lib:int-add m (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf ctemp + (f2cl-lib:fref c-%data% (j) ((1 *)) c-%offset%)) + (setf stemp + (f2cl-lib:fref s-%data% (j) ((1 *)) s-%offset%)) + (cond + ((or (/= ctemp one) (/= stemp zero)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add j 1) i) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add j 1) i) + ((1 lda) (1 *)) + a-%offset%) + (- (* ctemp temp) + (* stemp + (f2cl-lib:fref a-%data% + (j i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref a-%data% + (j i) + ((1 lda) (1 *)) + a-%offset%) + (+ (* stemp temp) + (* ctemp + (f2cl-lib:fref a-%data% + (j i) + ((1 lda) (1 *)) + a-%offset%))))))))))) + ((lsame direct "B") + (f2cl-lib:fdo (j (f2cl-lib:int-add m (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf ctemp + (f2cl-lib:fref c-%data% (j) ((1 *)) c-%offset%)) + (setf stemp + (f2cl-lib:fref s-%data% (j) ((1 *)) s-%offset%)) + (cond + ((or (/= ctemp one) (/= stemp zero)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add j 1) i) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add j 1) i) + ((1 lda) (1 *)) + a-%offset%) + (- (* ctemp temp) + (* stemp + (f2cl-lib:fref a-%data% + (j i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref a-%data% + (j i) + ((1 lda) (1 *)) + a-%offset%) + (+ (* stemp temp) + (* ctemp + (f2cl-lib:fref a-%data% + (j i) + ((1 lda) (1 *)) + a-%offset%))))))))))))) + ((lsame pivot "T") + (cond + ((lsame direct "F") + (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1)) + ((> j m) nil) + (tagbody + (setf ctemp + (f2cl-lib:fref c-%data% + ((f2cl-lib:int-sub j 1)) + ((1 *)) + c-%offset%)) + (setf stemp + (f2cl-lib:fref s-%data% + ((f2cl-lib:int-sub j 1)) + ((1 *)) + s-%offset%)) + (cond + ((or (/= ctemp one) (/= stemp zero)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp + (f2cl-lib:fref a-%data% + (j i) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + (j i) + ((1 lda) (1 *)) + a-%offset%) + (- (* ctemp temp) + (* stemp + (f2cl-lib:fref a-%data% + (1 i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref a-%data% + (1 i) + ((1 lda) (1 *)) + a-%offset%) + (+ (* stemp temp) + (* ctemp + (f2cl-lib:fref a-%data% + (1 i) + ((1 lda) (1 *)) + a-%offset%))))))))))) + ((lsame direct "B") + (f2cl-lib:fdo (j m (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 2) nil) + (tagbody + (setf ctemp + (f2cl-lib:fref c-%data% + ((f2cl-lib:int-sub j 1)) + ((1 *)) + c-%offset%)) + (setf stemp + (f2cl-lib:fref s-%data% + ((f2cl-lib:int-sub j 1)) + ((1 *)) + s-%offset%)) + (cond + ((or (/= ctemp one) (/= stemp zero)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp + (f2cl-lib:fref a-%data% + (j i) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + (j i) + ((1 lda) (1 *)) + a-%offset%) + (- (* ctemp temp) + (* stemp + (f2cl-lib:fref a-%data% + (1 i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref a-%data% + (1 i) + ((1 lda) (1 *)) + a-%offset%) + (+ (* stemp temp) + (* ctemp + (f2cl-lib:fref a-%data% + (1 i) + ((1 lda) (1 *)) + a-%offset%))))))))))))) + ((lsame pivot "B") + (cond + ((lsame direct "F") + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j (f2cl-lib:int-add m (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf ctemp + (f2cl-lib:fref c-%data% (j) ((1 *)) c-%offset%)) + (setf stemp + (f2cl-lib:fref s-%data% (j) ((1 *)) s-%offset%)) + (cond + ((or (/= ctemp one) (/= stemp zero)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp + (f2cl-lib:fref a-%data% + (j i) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + (j i) + ((1 lda) (1 *)) + a-%offset%) + (+ + (* stemp + (f2cl-lib:fref a-%data% + (m i) + ((1 lda) (1 *)) + a-%offset%)) + (* ctemp temp))) + (setf (f2cl-lib:fref a-%data% + (m i) + ((1 lda) (1 *)) + a-%offset%) + (- + (* ctemp + (f2cl-lib:fref a-%data% + (m i) + ((1 lda) (1 *)) + a-%offset%)) + (* stemp temp)))))))))) + ((lsame direct "B") + (f2cl-lib:fdo (j (f2cl-lib:int-add m (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf ctemp + (f2cl-lib:fref c-%data% (j) ((1 *)) c-%offset%)) + (setf stemp + (f2cl-lib:fref s-%data% (j) ((1 *)) s-%offset%)) + (cond + ((or (/= ctemp one) (/= stemp zero)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp + (f2cl-lib:fref a-%data% + (j i) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + (j i) + ((1 lda) (1 *)) + a-%offset%) + (+ + (* stemp + (f2cl-lib:fref a-%data% + (m i) + ((1 lda) (1 *)) + a-%offset%)) + (* ctemp temp))) + (setf (f2cl-lib:fref a-%data% + (m i) + ((1 lda) (1 *)) + a-%offset%) + (- + (* ctemp + (f2cl-lib:fref a-%data% + (m i) + ((1 lda) (1 *)) + a-%offset%)) + (* stemp temp)))))))))))))) + ((lsame side "R") + (cond + ((lsame pivot "V") + (cond + ((lsame direct "F") + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j (f2cl-lib:int-add n (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf ctemp + (f2cl-lib:fref c-%data% (j) ((1 *)) c-%offset%)) + (setf stemp + (f2cl-lib:fref s-%data% (j) ((1 *)) s-%offset%)) + (cond + ((or (/= ctemp one) (/= stemp zero)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (f2cl-lib:fref a-%data% + (i (f2cl-lib:int-add j 1)) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + (i (f2cl-lib:int-add j 1)) + ((1 lda) (1 *)) + a-%offset%) + (- (* ctemp temp) + (* stemp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ (* stemp temp) + (* ctemp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%))))))))))) + ((lsame direct "B") + (f2cl-lib:fdo (j (f2cl-lib:int-add n (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf ctemp + (f2cl-lib:fref c-%data% (j) ((1 *)) c-%offset%)) + (setf stemp + (f2cl-lib:fref s-%data% (j) ((1 *)) s-%offset%)) + (cond + ((or (/= ctemp one) (/= stemp zero)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (f2cl-lib:fref a-%data% + (i (f2cl-lib:int-add j 1)) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + (i (f2cl-lib:int-add j 1)) + ((1 lda) (1 *)) + a-%offset%) + (- (* ctemp temp) + (* stemp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ (* stemp temp) + (* ctemp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%))))))))))))) + ((lsame pivot "T") + (cond + ((lsame direct "F") + (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf ctemp + (f2cl-lib:fref c-%data% + ((f2cl-lib:int-sub j 1)) + ((1 *)) + c-%offset%)) + (setf stemp + (f2cl-lib:fref s-%data% + ((f2cl-lib:int-sub j 1)) + ((1 *)) + s-%offset%)) + (cond + ((or (/= ctemp one) (/= stemp zero)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (- (* ctemp temp) + (* stemp + (f2cl-lib:fref a-%data% + (i 1) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref a-%data% + (i 1) + ((1 lda) (1 *)) + a-%offset%) + (+ (* stemp temp) + (* ctemp + (f2cl-lib:fref a-%data% + (i 1) + ((1 lda) (1 *)) + a-%offset%))))))))))) + ((lsame direct "B") + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 2) nil) + (tagbody + (setf ctemp + (f2cl-lib:fref c-%data% + ((f2cl-lib:int-sub j 1)) + ((1 *)) + c-%offset%)) + (setf stemp + (f2cl-lib:fref s-%data% + ((f2cl-lib:int-sub j 1)) + ((1 *)) + s-%offset%)) + (cond + ((or (/= ctemp one) (/= stemp zero)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (- (* ctemp temp) + (* stemp + (f2cl-lib:fref a-%data% + (i 1) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref a-%data% + (i 1) + ((1 lda) (1 *)) + a-%offset%) + (+ (* stemp temp) + (* ctemp + (f2cl-lib:fref a-%data% + (i 1) + ((1 lda) (1 *)) + a-%offset%))))))))))))) + ((lsame pivot "B") + (cond + ((lsame direct "F") + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j (f2cl-lib:int-add n (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf ctemp + (f2cl-lib:fref c-%data% (j) ((1 *)) c-%offset%)) + (setf stemp + (f2cl-lib:fref s-%data% (j) ((1 *)) s-%offset%)) + (cond + ((or (/= ctemp one) (/= stemp zero)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (* stemp + (f2cl-lib:fref a-%data% + (i n) + ((1 lda) (1 *)) + a-%offset%)) + (* ctemp temp))) + (setf (f2cl-lib:fref a-%data% + (i n) + ((1 lda) (1 *)) + a-%offset%) + (- + (* ctemp + (f2cl-lib:fref a-%data% + (i n) + ((1 lda) (1 *)) + a-%offset%)) + (* stemp temp)))))))))) + ((lsame direct "B") + (f2cl-lib:fdo (j (f2cl-lib:int-add n (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf ctemp + (f2cl-lib:fref c-%data% (j) ((1 *)) c-%offset%)) + (setf stemp + (f2cl-lib:fref s-%data% (j) ((1 *)) s-%offset%)) + (cond + ((or (/= ctemp one) (/= stemp zero)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (* stemp + (f2cl-lib:fref a-%data% + (i n) + ((1 lda) (1 *)) + a-%offset%)) + (* ctemp temp))) + (setf (f2cl-lib:fref a-%data% + (i n) + ((1 lda) (1 *)) + a-%offset%) + (- + (* ctemp + (f2cl-lib:fref a-%data% + (i n) + ((1 lda) (1 *)) + a-%offset%)) + (* stemp temp))))))))))))))) + 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::dlasr 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)) + fixnum fixnum + (array double-float (*)) (array double-float (*)) + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasrt LAPACK} +\pagehead{dlasrt}{dlasrt} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((select 20)) + (declare (type (fixnum 20 20) select)) + (defun dlasrt (id n d info) + (declare (type (array double-float (*)) d) + (type fixnum info n) + (type (simple-array character (*)) id)) + (f2cl-lib:with-multi-array-data + ((id character id-%data% id-%offset%) + (d double-float d-%data% d-%offset%)) + (prog ((stack (make-array 64 :element-type 'fixnum)) (d1 0.0) + (d2 0.0) (d3 0.0) (dmnmx 0.0) (tmp 0.0) (dir 0) (endd 0) (i 0) + (j 0) (start 0) (stkpnt 0)) + (declare (type (array fixnum (64)) stack) + (type (double-float) d1 d2 d3 dmnmx tmp) + (type fixnum dir endd i j start stkpnt)) + (setf info 0) + (setf dir -1) + (cond + ((lsame id "D") + (setf dir 0)) + ((lsame id "I") + (setf dir 1))) + (cond + ((= dir (f2cl-lib:int-sub 1)) + (setf info -1)) + ((< n 0) + (setf info -2))) + (cond + ((/= info 0) + (xerbla "DLASRT" (f2cl-lib:int-sub info)) + (go end_label))) + (if (<= n 1) (go end_label)) + (setf stkpnt 1) + (setf (f2cl-lib:fref stack (1 1) ((1 2) (1 32))) 1) + (setf (f2cl-lib:fref stack (2 1) ((1 2) (1 32))) n) + label10 + (setf start (f2cl-lib:fref stack (1 stkpnt) ((1 2) (1 32)))) + (setf endd (f2cl-lib:fref stack (2 stkpnt) ((1 2) (1 32)))) + (setf stkpnt (f2cl-lib:int-sub stkpnt 1)) + (cond + ((and (<= (f2cl-lib:int-add endd (f2cl-lib:int-sub start)) select) + (> (f2cl-lib:int-add endd (f2cl-lib:int-sub start)) 0)) + (cond + ((= dir 0) + (f2cl-lib:fdo (i (f2cl-lib:int-add start 1) + (f2cl-lib:int-add i 1)) + ((> i endd) nil) + (tagbody + (f2cl-lib:fdo (j i (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j (f2cl-lib:int-add start 1)) nil) + (tagbody + (cond + ((> (f2cl-lib:fref d (j) ((1 *))) + (f2cl-lib:fref d + ((f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + ((1 *)))) + (setf dmnmx + (f2cl-lib:fref d-%data% + (j) + ((1 *)) + d-%offset%)) + (setf (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub j 1)) + ((1 *)) + d-%offset%)) + (setf (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub j 1)) + ((1 *)) + d-%offset%) + dmnmx)) + (t + (go label30))))) + label30))) + (t + (f2cl-lib:fdo (i (f2cl-lib:int-add start 1) + (f2cl-lib:int-add i 1)) + ((> i endd) nil) + (tagbody + (f2cl-lib:fdo (j i (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j (f2cl-lib:int-add start 1)) nil) + (tagbody + (cond + ((< (f2cl-lib:fref d (j) ((1 *))) + (f2cl-lib:fref d + ((f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + ((1 *)))) + (setf dmnmx + (f2cl-lib:fref d-%data% + (j) + ((1 *)) + d-%offset%)) + (setf (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub j 1)) + ((1 *)) + d-%offset%)) + (setf (f2cl-lib:fref d-%data% + ((f2cl-lib:int-sub j 1)) + ((1 *)) + d-%offset%) + dmnmx)) + (t + (go label50))))) + label50))))) + ((> (f2cl-lib:int-add endd (f2cl-lib:int-sub start)) select) + (setf d1 (f2cl-lib:fref d-%data% (start) ((1 *)) d-%offset%)) + (setf d2 (f2cl-lib:fref d-%data% (endd) ((1 *)) d-%offset%)) + (setf i (the fixnum (truncate (+ start endd) 2))) + (setf d3 (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) + (cond + ((< d1 d2) + (cond + ((< d3 d1) + (setf dmnmx d1)) + ((< d3 d2) + (setf dmnmx d3)) + (t + (setf dmnmx d2)))) + (t + (cond + ((< d3 d2) + (setf dmnmx d2)) + ((< d3 d1) + (setf dmnmx d3)) + (t + (setf dmnmx d1))))) + (cond + ((= dir 0) + (tagbody + (setf i (f2cl-lib:int-sub start 1)) + (setf j (f2cl-lib:int-add endd 1)) + label60 + (setf j (f2cl-lib:int-sub j 1)) + (if (< (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) dmnmx) + (go label60)) + label80 + (setf i (f2cl-lib:int-add i 1)) + (if (> (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) dmnmx) + (go label80)) + (cond + ((< i j) + (setf tmp (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) + (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%)) + (setf (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) tmp) + (go label60))) + (cond + ((> (f2cl-lib:int-add j (f2cl-lib:int-sub start)) + (f2cl-lib:int-add endd + (f2cl-lib:int-sub j) + (f2cl-lib:int-sub 1))) + (setf stkpnt (f2cl-lib:int-add stkpnt 1)) + (setf (f2cl-lib:fref stack (1 stkpnt) ((1 2) (1 32))) start) + (setf (f2cl-lib:fref stack (2 stkpnt) ((1 2) (1 32))) j) + (setf stkpnt (f2cl-lib:int-add stkpnt 1)) + (setf (f2cl-lib:fref stack (1 stkpnt) ((1 2) (1 32))) + (f2cl-lib:int-add j 1)) + (setf (f2cl-lib:fref stack (2 stkpnt) ((1 2) (1 32))) endd)) + (t + (setf stkpnt (f2cl-lib:int-add stkpnt 1)) + (setf (f2cl-lib:fref stack (1 stkpnt) ((1 2) (1 32))) + (f2cl-lib:int-add j 1)) + (setf (f2cl-lib:fref stack (2 stkpnt) ((1 2) (1 32))) endd) + (setf stkpnt (f2cl-lib:int-add stkpnt 1)) + (setf (f2cl-lib:fref stack (1 stkpnt) ((1 2) (1 32))) start) + (setf (f2cl-lib:fref stack (2 stkpnt) ((1 2) (1 32))) j))))) + (t + (tagbody + (setf i (f2cl-lib:int-sub start 1)) + (setf j (f2cl-lib:int-add endd 1)) + label90 + (setf j (f2cl-lib:int-sub j 1)) + (if (> (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) dmnmx) + (go label90)) + label110 + (setf i (f2cl-lib:int-add i 1)) + (if (< (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) dmnmx) + (go label110)) + (cond + ((< i j) + (setf tmp (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%)) + (setf (f2cl-lib:fref d-%data% (i) ((1 *)) d-%offset%) + (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%)) + (setf (f2cl-lib:fref d-%data% (j) ((1 *)) d-%offset%) tmp) + (go label90))) + (cond + ((> (f2cl-lib:int-add j (f2cl-lib:int-sub start)) + (f2cl-lib:int-add endd + (f2cl-lib:int-sub j) + (f2cl-lib:int-sub 1))) + (setf stkpnt (f2cl-lib:int-add stkpnt 1)) + (setf (f2cl-lib:fref stack (1 stkpnt) ((1 2) (1 32))) start) + (setf (f2cl-lib:fref stack (2 stkpnt) ((1 2) (1 32))) j) + (setf stkpnt (f2cl-lib:int-add stkpnt 1)) + (setf (f2cl-lib:fref stack (1 stkpnt) ((1 2) (1 32))) + (f2cl-lib:int-add j 1)) + (setf (f2cl-lib:fref stack (2 stkpnt) ((1 2) (1 32))) endd)) + (t + (setf stkpnt (f2cl-lib:int-add stkpnt 1)) + (setf (f2cl-lib:fref stack (1 stkpnt) ((1 2) (1 32))) + (f2cl-lib:int-add j 1)) + (setf (f2cl-lib:fref stack (2 stkpnt) ((1 2) (1 32))) endd) + (setf stkpnt (f2cl-lib:int-add stkpnt 1)) + (setf (f2cl-lib:fref stack (1 stkpnt) ((1 2) (1 32))) start) + (setf (f2cl-lib:fref stack (2 stkpnt) ((1 2) (1 32))) + j)))))))) + (if (> stkpnt 0) (go label10)) + end_label + (return (values 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::dlasrt + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum (array double-float (*)) + fixnum) + :return-values '(nil nil nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlassq LAPACK} +\pagehead{dlassq}{dlassq} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dlassq (n x incx scale sumsq) + (declare (type (double-float) sumsq scale) + (type (array double-float (*)) x) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((x double-float x-%data% x-%offset%)) + (prog ((absxi 0.0) (ix 0)) + (declare (type (double-float) absxi) (type fixnum ix)) + (cond + ((> n 0) + (f2cl-lib:fdo (ix 1 (f2cl-lib:int-add ix incx)) + ((> ix + (f2cl-lib:int-add 1 + (f2cl-lib:int-mul + (f2cl-lib:int-add n + (f2cl-lib:int-sub 1)) + incx))) + nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (ix) ((1 *))) zero) + (setf absxi + (abs + (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%))) + (cond + ((< scale absxi) + (setf sumsq (+ 1 (* sumsq (expt (/ scale absxi) 2)))) + (setf scale absxi)) + (t + (setf sumsq (+ sumsq (expt (/ absxi scale) 2))))))))))) + (return (values nil nil nil scale sumsq)))))) + +(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::dlassq + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum (array double-float (*)) + fixnum (double-float) + (double-float)) + :return-values '(nil nil nil fortran-to-lisp::scale + fortran-to-lisp::sumsq) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasv2 LAPACK} +\pagehead{dlasv2}{dlasv2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0) (half 0.5) (one 1.0) (two 2.0) (four 4.0)) + (declare (type (double-float 0.0 0.0) zero) + (type (double-float 0.5 0.5) half) + (type (double-float 1.0 1.0) one) + (type (double-float 2.0 2.0) two) + (type (double-float 4.0 4.0) four)) + (defun dlasv2 (f g h ssmin ssmax snr csr snl csl) + (declare (type (double-float) csl snl csr snr ssmax ssmin h g f)) + (prog ((a 0.0) (clt 0.0) (crt 0.0) (d 0.0) (fa 0.0) (ft 0.0) (ga 0.0) + (gt 0.0) (ha 0.0) (ht 0.0) (l 0.0) (m 0.0) (mm 0.0) (r 0.0) (s 0.0) + (slt 0.0) (srt 0.0) (t$ 0.0) (temp 0.0) (tsign 0.0) (tt 0.0) + (pmax 0) (gasmal nil) (swap nil)) + (declare (type (double-float) a clt crt d fa ft ga gt ha ht l m mm r s + slt srt t$ temp tsign tt) + (type fixnum pmax) + (type (member t nil) gasmal swap)) + (setf ft f) + (setf fa (abs ft)) + (setf ht h) + (setf ha (abs h)) + (setf pmax 1) + (setf swap (> ha fa)) + (cond + (swap + (setf pmax 3) + (setf temp ft) + (setf ft ht) + (setf ht temp) + (setf temp fa) + (setf fa ha) + (setf ha temp))) + (setf gt g) + (setf ga (abs gt)) + (cond + ((= ga zero) + (setf ssmin ha) + (setf ssmax fa) + (setf clt one) + (setf crt one) + (setf slt zero) + (setf srt zero)) + (t + (setf gasmal t) + (cond + ((> ga fa) + (setf pmax 2) + (cond + ((< (f2cl-lib:f2cl/ fa ga) (dlamch "EPS")) + (setf gasmal nil) + (setf ssmax ga) + (cond + ((> ha one) + (setf ssmin (/ fa (/ ga ha)))) + (t + (setf ssmin (* (/ fa ga) ha)))) + (setf clt one) + (setf slt (/ ht gt)) + (setf srt one) + (setf crt (/ ft gt)))))) + (cond + (gasmal + (setf d (- fa ha)) + (cond + ((= d fa) + (setf l one)) + (t + (setf l (/ d fa)))) + (setf m (/ gt ft)) + (setf t$ (- two l)) + (setf mm (* m m)) + (setf tt (* t$ t$)) + (setf s (f2cl-lib:fsqrt (+ tt mm))) + (cond + ((= l zero) + (setf r (abs m))) + (t + (setf r (f2cl-lib:fsqrt (+ (* l l) mm))))) + (setf a (* half (+ s r))) + (setf ssmin (/ ha a)) + (setf ssmax (* fa a)) + (cond + ((= mm zero) + (cond + ((= l zero) + (setf t$ (* (f2cl-lib:sign two ft) (f2cl-lib:sign one gt)))) + (t + (setf t$ (+ (/ gt (f2cl-lib:sign d ft)) (/ m t$)))))) + (t + (setf t$ (* (+ (/ m (+ s t$)) (/ m (+ r l))) (+ one a))))) + (setf l (f2cl-lib:fsqrt (+ (* t$ t$) four))) + (setf crt (/ two l)) + (setf srt (/ t$ l)) + (setf clt (/ (+ crt (* srt m)) a)) + (setf slt (/ (* (/ ht ft) srt) a)))))) + (cond + (swap + (setf csl srt) + (setf snl crt) + (setf csr slt) + (setf snr clt)) + (t + (setf csl clt) + (setf snl slt) + (setf csr crt) + (setf snr srt))) + (if (= pmax 1) + (setf tsign + (* (f2cl-lib:sign one csr) + (f2cl-lib:sign one csl) + (f2cl-lib:sign one f)))) + (if (= pmax 2) + (setf tsign + (* (f2cl-lib:sign one snr) + (f2cl-lib:sign one csl) + (f2cl-lib:sign one g)))) + (if (= pmax 3) + (setf tsign + (* (f2cl-lib:sign one snr) + (f2cl-lib:sign one snl) + (f2cl-lib:sign one h)))) + (setf ssmax (f2cl-lib:sign ssmax tsign)) + (setf ssmin + (f2cl-lib:sign ssmin + (* tsign + (f2cl-lib:sign one f) + (f2cl-lib:sign one h)))) + (return (values nil nil nil ssmin ssmax snr csr snl csl))))) + +(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::dlasv2 + 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) + (double-float) (double-float) (double-float)) + :return-values '(nil nil nil fortran-to-lisp::ssmin + fortran-to-lisp::ssmax fortran-to-lisp::snr + fortran-to-lisp::csr fortran-to-lisp::snl + fortran-to-lisp::csl) + :calls '(fortran-to-lisp::dlamch)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlaswp LAPACK} +\pagehead{dlaswp}{dlaswp} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun dlaswp (n a lda k1 k2 ipiv incx) + (declare (type (array fixnum (*)) ipiv) + (type (array double-float (*)) a) + (type fixnum incx k2 k1 lda n)) + (f2cl-lib:with-multi-array-data + ((a double-float a-%data% a-%offset%) + (ipiv fixnum ipiv-%data% ipiv-%offset%)) + (prog ((temp 0.0) (i 0) (i1 0) (i2 0) (inc 0) (ip 0) (ix 0) (ix0 0) (j 0) + (k 0) (n32 0)) + (declare (type fixnum n32 k j ix0 ix ip inc i2 i1 i) + (type (double-float) temp)) + (cond + ((> incx 0) + (setf ix0 k1) + (setf i1 k1) + (setf i2 k2) + (setf inc 1)) + ((< incx 0) + (setf ix0 + (f2cl-lib:int-add 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 k2) + incx))) + (setf i1 k2) + (setf i2 k1) + (setf inc -1)) + (t + (go end_label))) + (setf n32 (* (the fixnum (truncate n 32)) 32)) + (cond + ((/= n32 0) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 32)) + ((> j n32) nil) + (tagbody + (setf ix ix0) + (f2cl-lib:fdo (i i1 (f2cl-lib:int-add i inc)) + ((> i i2) nil) + (tagbody + (setf ip + (f2cl-lib:fref ipiv-%data% + (ix) + ((1 *)) + ipiv-%offset%)) + (cond + ((/= ip i) + (f2cl-lib:fdo (k j (f2cl-lib:int-add k 1)) + ((> k (f2cl-lib:int-add j 31)) nil) + (tagbody + (setf temp + (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref a-%data% + (ip k) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + (ip k) + ((1 lda) (1 *)) + a-%offset%) + temp))))) + (setf ix (f2cl-lib:int-add ix incx)))))))) + (cond + ((/= n32 n) + (setf n32 (f2cl-lib:int-add n32 1)) + (setf ix ix0) + (f2cl-lib:fdo (i i1 (f2cl-lib:int-add i inc)) + ((> i i2) nil) + (tagbody + (setf ip (f2cl-lib:fref ipiv-%data% (ix) ((1 *)) ipiv-%offset%)) + (cond + ((/= ip i) + (f2cl-lib:fdo (k n32 (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (setf temp + (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref a-%data% + (ip k) + ((1 lda) (1 *)) + a-%offset%)) + (setf (f2cl-lib:fref a-%data% + (ip k) + ((1 lda) (1 *)) + a-%offset%) + temp))))) + (setf ix (f2cl-lib:int-add ix incx)))))) + 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::dlaswp + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum (array double-float (*)) + fixnum fixnum + fixnum + (array fixnum (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dlasy2 LAPACK} +\pagehead{dlasy2}{dlasy2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0) (one 1.0) (two 2.0) (half 0.5) (eight 8.0)) + (declare (type (double-float 0.0 0.0) zero) + (type (double-float 1.0 1.0) one) + (type (double-float 2.0 2.0) two) + (type (double-float 0.5 0.5) half) + (type (double-float 8.0 8.0) eight)) + (let ((locu12 + (make-array 4 + :element-type 'fixnum + :initial-contents '(3 4 1 2))) + (locl21 + (make-array 4 + :element-type 'fixnum + :initial-contents '(2 1 4 3))) + (locu22 + (make-array 4 + :element-type 'fixnum + :initial-contents '(4 3 2 1))) + (xswpiv + (make-array 4 :element-type 't :initial-contents '(nil nil t t))) + (bswpiv + (make-array 4 :element-type 't :initial-contents '(nil t nil t)))) + (declare (type (array (member t nil) (4)) bswpiv xswpiv) + (type (array fixnum (4)) locu22 locl21 locu12)) + (defun dlasy2 + (ltranl ltranr isgn n1 n2 tl ldtl tr ldtr b ldb$ scale x ldx xnorm + info) + (declare (type (double-float) xnorm scale) + (type (array double-float (*)) x b tr tl) + (type fixnum info ldx ldb$ ldtr ldtl n2 n1 isgn) + (type (member t nil) ltranr ltranl)) + (f2cl-lib:with-multi-array-data + ((tl double-float tl-%data% tl-%offset%) + (tr double-float tr-%data% tr-%offset%) + (b double-float b-%data% b-%offset%) + (x double-float x-%data% x-%offset%)) + (prog ((btmp (make-array 4 :element-type 'double-float)) + (t16 (make-array 16 :element-type 'double-float)) + (tmp (make-array 4 :element-type 'double-float)) + (x2 (make-array 2 :element-type 'double-float)) + (jpiv (make-array 4 :element-type 'fixnum)) (bet 0.0) + (eps 0.0) (gam 0.0) (l21 0.0) (sgn 0.0) (smin 0.0) (smlnum 0.0) + (tau1 0.0) (temp 0.0) (u11 0.0) (u12 0.0) (u22 0.0) (xmax 0.0) + (i 0) (ip 0) (ipiv 0) (ipsv 0) (j 0) (jp 0) (jpsv 0) (k 0) + (bswap nil) (xswap nil)) + (declare (type (array double-float (16)) t16) + (type (array double-float (4)) btmp tmp) + (type (array double-float (2)) x2) + (type (array fixnum (4)) jpiv) + (type (double-float) bet eps gam l21 sgn smin smlnum tau1 + temp u11 u12 u22 xmax) + (type fixnum i ip ipiv ipsv j jp jpsv k) + (type (member t nil) bswap xswap)) + (setf info 0) + (if (or (= n1 0) (= n2 0)) (go end_label)) + (setf eps (dlamch "P")) + (setf smlnum (/ (dlamch "S") eps)) + (setf sgn (coerce (the fixnum isgn) 'double-float)) + (setf k (f2cl-lib:int-sub (f2cl-lib:int-add n1 n1 n2) 2)) + (f2cl-lib:computed-goto (label10 label20 label30 label50) k) + label10 + (setf tau1 + (+ + (f2cl-lib:fref tl-%data% (1 1) ((1 ldtl) (1 *)) tl-%offset%) + (* sgn + (f2cl-lib:fref tr-%data% + (1 1) + ((1 ldtr) (1 *)) + tr-%offset%)))) + (setf bet (abs tau1)) + (cond + ((<= bet smlnum) + (setf tau1 smlnum) + (setf bet smlnum) + (setf info 1))) + (setf scale one) + (setf gam + (abs + (f2cl-lib:fref b-%data% (1 1) ((1 ldb$) (1 *)) b-%offset%))) + (if (> (* smlnum gam) bet) (setf scale (/ one gam))) + (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) + tau1)) + (setf xnorm + (abs + (f2cl-lib:fref x-%data% (1 1) ((1 ldx) (1 *)) x-%offset%))) + (go end_label) + label20 + (setf smin + (max + (* eps + (max + (abs + (f2cl-lib:fref tl-%data% + (1 1) + ((1 ldtl) (1 *)) + tl-%offset%)) + (abs + (f2cl-lib:fref tr-%data% + (1 1) + ((1 ldtr) (1 *)) + tr-%offset%)) + (abs + (f2cl-lib:fref tr-%data% + (1 2) + ((1 ldtr) (1 *)) + tr-%offset%)) + (abs + (f2cl-lib:fref tr-%data% + (2 1) + ((1 ldtr) (1 *)) + tr-%offset%)) + (abs + (f2cl-lib:fref tr-%data% + (2 2) + ((1 ldtr) (1 *)) + tr-%offset%)))) + smlnum)) + (setf (f2cl-lib:fref tmp (1) ((1 4))) + (+ + (f2cl-lib:fref tl-%data% (1 1) ((1 ldtl) (1 *)) tl-%offset%) + (* sgn + (f2cl-lib:fref tr-%data% + (1 1) + ((1 ldtr) (1 *)) + tr-%offset%)))) + (setf (f2cl-lib:fref tmp (4) ((1 4))) + (+ + (f2cl-lib:fref tl-%data% (1 1) ((1 ldtl) (1 *)) tl-%offset%) + (* sgn + (f2cl-lib:fref tr-%data% + (2 2) + ((1 ldtr) (1 *)) + tr-%offset%)))) + (cond + (ltranr + (setf (f2cl-lib:fref tmp (2) ((1 4))) + (* sgn + (f2cl-lib:fref tr-%data% + (2 1) + ((1 ldtr) (1 *)) + tr-%offset%))) + (setf (f2cl-lib:fref tmp (3) ((1 4))) + (* sgn + (f2cl-lib:fref tr-%data% + (1 2) + ((1 ldtr) (1 *)) + tr-%offset%)))) + (t + (setf (f2cl-lib:fref tmp (2) ((1 4))) + (* sgn + (f2cl-lib:fref tr-%data% + (1 2) + ((1 ldtr) (1 *)) + tr-%offset%))) + (setf (f2cl-lib:fref tmp (3) ((1 4))) + (* sgn + (f2cl-lib:fref tr-%data% + (2 1) + ((1 ldtr) (1 *)) + tr-%offset%))))) + (setf (f2cl-lib:fref btmp (1) ((1 4))) + (f2cl-lib:fref b-%data% (1 1) ((1 ldb$) (1 *)) b-%offset%)) + (setf (f2cl-lib:fref btmp (2) ((1 4))) + (f2cl-lib:fref b-%data% (1 2) ((1 ldb$) (1 *)) b-%offset%)) + (go label40) + label30 + (setf smin + (max + (* eps + (max + (abs + (f2cl-lib:fref tr-%data% + (1 1) + ((1 ldtr) (1 *)) + tr-%offset%)) + (abs + (f2cl-lib:fref tl-%data% + (1 1) + ((1 ldtl) (1 *)) + tl-%offset%)) + (abs + (f2cl-lib:fref tl-%data% + (1 2) + ((1 ldtl) (1 *)) + tl-%offset%)) + (abs + (f2cl-lib:fref tl-%data% + (2 1) + ((1 ldtl) (1 *)) + tl-%offset%)) + (abs + (f2cl-lib:fref tl-%data% + (2 2) + ((1 ldtl) (1 *)) + tl-%offset%)))) + smlnum)) + (setf (f2cl-lib:fref tmp (1) ((1 4))) + (+ + (f2cl-lib:fref tl-%data% (1 1) ((1 ldtl) (1 *)) tl-%offset%) + (* sgn + (f2cl-lib:fref tr-%data% + (1 1) + ((1 ldtr) (1 *)) + tr-%offset%)))) + (setf (f2cl-lib:fref tmp (4) ((1 4))) + (+ + (f2cl-lib:fref tl-%data% (2 2) ((1 ldtl) (1 *)) tl-%offset%) + (* sgn + (f2cl-lib:fref tr-%data% + (1 1) + ((1 ldtr) (1 *)) + tr-%offset%)))) + (cond + (ltranl + (setf (f2cl-lib:fref tmp (2) ((1 4))) + (f2cl-lib:fref tl-%data% + (1 2) + ((1 ldtl) (1 *)) + tl-%offset%)) + (setf (f2cl-lib:fref tmp (3) ((1 4))) + (f2cl-lib:fref tl-%data% + (2 1) + ((1 ldtl) (1 *)) + tl-%offset%))) + (t + (setf (f2cl-lib:fref tmp (2) ((1 4))) + (f2cl-lib:fref tl-%data% + (2 1) + ((1 ldtl) (1 *)) + tl-%offset%)) + (setf (f2cl-lib:fref tmp (3) ((1 4))) + (f2cl-lib:fref tl-%data% + (1 2) + ((1 ldtl) (1 *)) + tl-%offset%)))) + (setf (f2cl-lib:fref btmp (1) ((1 4))) + (f2cl-lib:fref b-%data% (1 1) ((1 ldb$) (1 *)) b-%offset%)) + (setf (f2cl-lib:fref btmp (2) ((1 4))) + (f2cl-lib:fref b-%data% (2 1) ((1 ldb$) (1 *)) b-%offset%)) + label40 + (setf ipiv (idamax 4 tmp 1)) + (setf u11 (f2cl-lib:fref tmp (ipiv) ((1 4)))) + (cond + ((<= (abs u11) smin) + (setf info 1) + (setf u11 smin))) + (setf u12 + (f2cl-lib:fref tmp + ((f2cl-lib:fref locu12 (ipiv) ((1 4)))) + ((1 4)))) + (setf l21 + (/ + (f2cl-lib:fref tmp + ((f2cl-lib:fref locl21 (ipiv) ((1 4)))) + ((1 4))) + u11)) + (setf u22 + (- + (f2cl-lib:fref tmp + ((f2cl-lib:fref locu22 (ipiv) ((1 4)))) + ((1 4))) + (* u12 l21))) + (setf xswap (f2cl-lib:fref xswpiv (ipiv) ((1 4)))) + (setf bswap (f2cl-lib:fref bswpiv (ipiv) ((1 4)))) + (cond + ((<= (abs u22) smin) + (setf info 1) + (setf u22 smin))) + (cond + (bswap + (setf temp (f2cl-lib:fref btmp (2) ((1 4)))) + (setf (f2cl-lib:fref btmp (2) ((1 4))) + (- (f2cl-lib:fref btmp (1) ((1 4))) (* l21 temp))) + (setf (f2cl-lib:fref btmp (1) ((1 4))) temp)) + (t + (setf (f2cl-lib:fref btmp (2) ((1 4))) + (- (f2cl-lib:fref btmp (2) ((1 4))) + (* l21 (f2cl-lib:fref btmp (1) ((1 4)))))))) + (setf scale one) + (cond + ((or + (> (* two smlnum (abs (f2cl-lib:fref btmp (2) ((1 4))))) + (abs u22)) + (> (* two smlnum (abs (f2cl-lib:fref btmp (1) ((1 4))))) + (abs u11))) + (setf scale + (/ half + (max (abs (f2cl-lib:fref btmp (1) ((1 4)))) + (abs (f2cl-lib:fref btmp (2) ((1 4))))))) + (setf (f2cl-lib:fref btmp (1) ((1 4))) + (* (f2cl-lib:fref btmp (1) ((1 4))) scale)) + (setf (f2cl-lib:fref btmp (2) ((1 4))) + (* (f2cl-lib:fref btmp (2) ((1 4))) scale)))) + (setf (f2cl-lib:fref x2 (2) ((1 2))) + (/ (f2cl-lib:fref btmp (2) ((1 4))) u22)) + (setf (f2cl-lib:fref x2 (1) ((1 2))) + (- (/ (f2cl-lib:fref btmp (1) ((1 4))) u11) + (* (/ u12 u11) (f2cl-lib:fref x2 (2) ((1 2)))))) + (cond + (xswap + (setf temp (f2cl-lib:fref x2 (2) ((1 2)))) + (setf (f2cl-lib:fref x2 (2) ((1 2))) + (f2cl-lib:fref x2 (1) ((1 2)))) + (setf (f2cl-lib:fref x2 (1) ((1 2))) temp))) + (setf (f2cl-lib:fref x-%data% (1 1) ((1 ldx) (1 *)) x-%offset%) + (f2cl-lib:fref x2 (1) ((1 2)))) + (cond + ((= n1 1) + (setf (f2cl-lib:fref x-%data% (1 2) ((1 ldx) (1 *)) x-%offset%) + (f2cl-lib:fref x2 (2) ((1 2)))) + (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 x-%data% (2 1) ((1 ldx) (1 *)) x-%offset%) + (f2cl-lib:fref x2 (2) ((1 2)))) + (setf xnorm + (max + (abs + (f2cl-lib:fref x-%data% + (1 1) + ((1 ldx) (1 *)) + x-%offset%)) + (abs + (f2cl-lib:fref x-%data% + (2 1) + ((1 ldx) (1 *)) + x-%offset%)))))) + (go end_label) + label50 + (setf smin + (max + (abs + (f2cl-lib:fref tr-%data% + (1 1) + ((1 ldtr) (1 *)) + tr-%offset%)) + (abs + (f2cl-lib:fref tr-%data% + (1 2) + ((1 ldtr) (1 *)) + tr-%offset%)) + (abs + (f2cl-lib:fref tr-%data% + (2 1) + ((1 ldtr) (1 *)) + tr-%offset%)) + (abs + (f2cl-lib:fref tr-%data% + (2 2) + ((1 ldtr) (1 *)) + tr-%offset%)))) + (setf smin + (max smin + (abs + (f2cl-lib:fref tl-%data% + (1 1) + ((1 ldtl) (1 *)) + tl-%offset%)) + (abs + (f2cl-lib:fref tl-%data% + (1 2) + ((1 ldtl) (1 *)) + tl-%offset%)) + (abs + (f2cl-lib:fref tl-%data% + (2 1) + ((1 ldtl) (1 *)) + tl-%offset%)) + (abs + (f2cl-lib:fref tl-%data% + (2 2) + ((1 ldtl) (1 *)) + tl-%offset%)))) + (setf smin (max (* eps smin) smlnum)) + (setf (f2cl-lib:fref btmp (1) ((1 4))) zero) + (dcopy 16 btmp 0 t16 1) + (setf (f2cl-lib:fref t16 (1 1) ((1 4) (1 4))) + (+ + (f2cl-lib:fref tl-%data% (1 1) ((1 ldtl) (1 *)) tl-%offset%) + (* sgn + (f2cl-lib:fref tr-%data% + (1 1) + ((1 ldtr) (1 *)) + tr-%offset%)))) + (setf (f2cl-lib:fref t16 (2 2) ((1 4) (1 4))) + (+ + (f2cl-lib:fref tl-%data% (2 2) ((1 ldtl) (1 *)) tl-%offset%) + (* sgn + (f2cl-lib:fref tr-%data% + (1 1) + ((1 ldtr) (1 *)) + tr-%offset%)))) + (setf (f2cl-lib:fref t16 (3 3) ((1 4) (1 4))) + (+ + (f2cl-lib:fref tl-%data% (1 1) ((1 ldtl) (1 *)) tl-%offset%) + (* sgn + (f2cl-lib:fref tr-%data% + (2 2) + ((1 ldtr) (1 *)) + tr-%offset%)))) + (setf (f2cl-lib:fref t16 (4 4) ((1 4) (1 4))) + (+ + (f2cl-lib:fref tl-%data% (2 2) ((1 ldtl) (1 *)) tl-%offset%) + (* sgn + (f2cl-lib:fref tr-%data% + (2 2) + ((1 ldtr) (1 *)) + tr-%offset%)))) + (cond + (ltranl + (setf (f2cl-lib:fref t16 (1 2) ((1 4) (1 4))) + (f2cl-lib:fref tl-%data% + (2 1) + ((1 ldtl) (1 *)) + tl-%offset%)) + (setf (f2cl-lib:fref t16 (2 1) ((1 4) (1 4))) + (f2cl-lib:fref tl-%data% + (1 2) + ((1 ldtl) (1 *)) + tl-%offset%)) + (setf (f2cl-lib:fref t16 (3 4) ((1 4) (1 4))) + (f2cl-lib:fref tl-%data% + (2 1) + ((1 ldtl) (1 *)) + tl-%offset%)) + (setf (f2cl-lib:fref t16 (4 3) ((1 4) (1 4))) + (f2cl-lib:fref tl-%data% + (1 2) + ((1 ldtl) (1 *)) + tl-%offset%))) + (t + (setf (f2cl-lib:fref t16 (1 2) ((1 4) (1 4))) + (f2cl-lib:fref tl-%data% + (1 2) + ((1 ldtl) (1 *)) + tl-%offset%)) + (setf (f2cl-lib:fref t16 (2 1) ((1 4) (1 4))) + (f2cl-lib:fref tl-%data% + (2 1) + ((1 ldtl) (1 *)) + tl-%offset%)) + (setf (f2cl-lib:fref t16 (3 4) ((1 4) (1 4))) + (f2cl-lib:fref tl-%data% + (1 2) + ((1 ldtl) (1 *)) + tl-%offset%)) + (setf (f2cl-lib:fref t16 (4 3) ((1 4) (1 4))) + (f2cl-lib:fref tl-%data% + (2 1) + ((1 ldtl) (1 *)) + tl-%offset%)))) + (cond + (ltranr + (setf (f2cl-lib:fref t16 (1 3) ((1 4) (1 4))) + (* sgn + (f2cl-lib:fref tr-%data% + (1 2) + ((1 ldtr) (1 *)) + tr-%offset%))) + (setf (f2cl-lib:fref t16 (2 4) ((1 4) (1 4))) + (* sgn + (f2cl-lib:fref tr-%data% + (1 2) + ((1 ldtr) (1 *)) + tr-%offset%))) + (setf (f2cl-lib:fref t16 (3 1) ((1 4) (1 4))) + (* sgn + (f2cl-lib:fref tr-%data% + (2 1) + ((1 ldtr) (1 *)) + tr-%offset%))) + (setf (f2cl-lib:fref t16 (4 2) ((1 4) (1 4))) + (* sgn + (f2cl-lib:fref tr-%data% + (2 1) + ((1 ldtr) (1 *)) + tr-%offset%)))) + (t + (setf (f2cl-lib:fref t16 (1 3) ((1 4) (1 4))) + (* sgn + (f2cl-lib:fref tr-%data% + (2 1) + ((1 ldtr) (1 *)) + tr-%offset%))) + (setf (f2cl-lib:fref t16 (2 4) ((1 4) (1 4))) + (* sgn + (f2cl-lib:fref tr-%data% + (2 1) + ((1 ldtr) (1 *)) + tr-%offset%))) + (setf (f2cl-lib:fref t16 (3 1) ((1 4) (1 4))) + (* sgn + (f2cl-lib:fref tr-%data% + (1 2) + ((1 ldtr) (1 *)) + tr-%offset%))) + (setf (f2cl-lib:fref t16 (4 2) ((1 4) (1 4))) + (* sgn + (f2cl-lib:fref tr-%data% + (1 2) + ((1 ldtr) (1 *)) + tr-%offset%))))) + (setf (f2cl-lib:fref btmp (1) ((1 4))) + (f2cl-lib:fref b-%data% (1 1) ((1 ldb$) (1 *)) b-%offset%)) + (setf (f2cl-lib:fref btmp (2) ((1 4))) + (f2cl-lib:fref b-%data% (2 1) ((1 ldb$) (1 *)) b-%offset%)) + (setf (f2cl-lib:fref btmp (3) ((1 4))) + (f2cl-lib:fref b-%data% (1 2) ((1 ldb$) (1 *)) b-%offset%)) + (setf (f2cl-lib:fref btmp (4) ((1 4))) + (f2cl-lib:fref b-%data% (2 2) ((1 ldb$) (1 *)) b-%offset%)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i 3) nil) + (tagbody + (setf xmax zero) + (f2cl-lib:fdo (ip i (f2cl-lib:int-add ip 1)) + ((> ip 4) nil) + (tagbody + (f2cl-lib:fdo (jp i (f2cl-lib:int-add jp 1)) + ((> jp 4) nil) + (tagbody + (cond + ((>= (abs (f2cl-lib:fref t16 (ip jp) ((1 4) (1 4)))) + xmax) + (setf xmax + (abs + (f2cl-lib:fref t16 (ip jp) ((1 4) (1 4))))) + (setf ipsv ip) + (setf jpsv jp))))))) + (cond + ((/= ipsv i) + (dswap 4 + (f2cl-lib:array-slice t16 + double-float + (ipsv 1) + ((1 4) (1 4))) + 4 (f2cl-lib:array-slice t16 double-float (i 1) ((1 4) (1 4))) + 4) + (setf temp (f2cl-lib:fref btmp (i) ((1 4)))) + (setf (f2cl-lib:fref btmp (i) ((1 4))) + (f2cl-lib:fref btmp (ipsv) ((1 4)))) + (setf (f2cl-lib:fref btmp (ipsv) ((1 4))) temp))) + (if (/= jpsv i) + (dswap 4 + (f2cl-lib:array-slice t16 + double-float + (1 jpsv) + ((1 4) (1 4))) + 1 + (f2cl-lib:array-slice t16 double-float (1 i) ((1 4) (1 4))) + 1)) + (setf (f2cl-lib:fref jpiv (i) ((1 4))) jpsv) + (cond + ((< (abs (f2cl-lib:fref t16 (i i) ((1 4) (1 4)))) smin) + (setf info 1) + (setf (f2cl-lib:fref t16 (i i) ((1 4) (1 4))) smin))) + (f2cl-lib:fdo (j (f2cl-lib:int-add i 1) (f2cl-lib:int-add j 1)) + ((> j 4) nil) + (tagbody + (setf (f2cl-lib:fref t16 (j i) ((1 4) (1 4))) + (/ (f2cl-lib:fref t16 (j i) ((1 4) (1 4))) + (f2cl-lib:fref t16 (i i) ((1 4) (1 4))))) + (setf (f2cl-lib:fref btmp (j) ((1 4))) + (- (f2cl-lib:fref btmp (j) ((1 4))) + (* (f2cl-lib:fref t16 (j i) ((1 4) (1 4))) + (f2cl-lib:fref btmp (i) ((1 4)))))) + (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) + (f2cl-lib:int-add k 1)) + ((> k 4) nil) + (tagbody + (setf (f2cl-lib:fref t16 (j k) ((1 4) (1 4))) + (- (f2cl-lib:fref t16 (j k) ((1 4) (1 4))) + (* (f2cl-lib:fref t16 (j i) ((1 4) (1 4))) + (f2cl-lib:fref t16 (i k) ((1 4) (1 4)))))))))))) + (if (< (abs (f2cl-lib:fref t16 (4 4) ((1 4) (1 4)))) smin) + (setf (f2cl-lib:fref t16 (4 4) ((1 4) (1 4))) smin)) + (setf scale one) + (cond + ((or + (> (* eight smlnum (abs (f2cl-lib:fref btmp (1) ((1 4))))) + (abs (f2cl-lib:fref t16 (1 1) ((1 4) (1 4))))) + (> (* eight smlnum (abs (f2cl-lib:fref btmp (2) ((1 4))))) + (abs (f2cl-lib:fref t16 (2 2) ((1 4) (1 4))))) + (> (* eight smlnum (abs (f2cl-lib:fref btmp (3) ((1 4))))) + (abs (f2cl-lib:fref t16 (3 3) ((1 4) (1 4))))) + (> (* eight smlnum (abs (f2cl-lib:fref btmp (4) ((1 4))))) + (abs (f2cl-lib:fref t16 (4 4) ((1 4) (1 4)))))) + (setf scale + (/ (/ one eight) + (max (abs (f2cl-lib:fref btmp (1) ((1 4)))) + (abs (f2cl-lib:fref btmp (2) ((1 4)))) + (abs (f2cl-lib:fref btmp (3) ((1 4)))) + (abs (f2cl-lib:fref btmp (4) ((1 4))))))) + (setf (f2cl-lib:fref btmp (1) ((1 4))) + (* (f2cl-lib:fref btmp (1) ((1 4))) scale)) + (setf (f2cl-lib:fref btmp (2) ((1 4))) + (* (f2cl-lib:fref btmp (2) ((1 4))) scale)) + (setf (f2cl-lib:fref btmp (3) ((1 4))) + (* (f2cl-lib:fref btmp (3) ((1 4))) scale)) + (setf (f2cl-lib:fref btmp (4) ((1 4))) + (* (f2cl-lib:fref btmp (4) ((1 4))) scale)))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i 4) nil) + (tagbody + (setf k (f2cl-lib:int-sub 5 i)) + (setf temp (/ one (f2cl-lib:fref t16 (k k) ((1 4) (1 4))))) + (setf (f2cl-lib:fref tmp (k) ((1 4))) + (* (f2cl-lib:fref btmp (k) ((1 4))) temp)) + (f2cl-lib:fdo (j (f2cl-lib:int-add k 1) (f2cl-lib:int-add j 1)) + ((> j 4) nil) + (tagbody + (setf (f2cl-lib:fref tmp (k) ((1 4))) + (- (f2cl-lib:fref tmp (k) ((1 4))) + (* temp + (f2cl-lib:fref t16 (k j) ((1 4) (1 4))) + (f2cl-lib:fref tmp (j) ((1 4)))))))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i 3) nil) + (tagbody + (cond + ((/= + (f2cl-lib:fref jpiv + ((f2cl-lib:int-add 4 (f2cl-lib:int-sub i))) + ((1 4))) + (f2cl-lib:int-add 4 (f2cl-lib:int-sub i))) + (setf temp + (f2cl-lib:fref tmp ((f2cl-lib:int-sub 4 i)) ((1 4)))) + (setf (f2cl-lib:fref tmp ((f2cl-lib:int-sub 4 i)) ((1 4))) + (f2cl-lib:fref tmp + ((f2cl-lib:fref jpiv + ((f2cl-lib:int-sub 4 + i)) + ((1 4)))) + ((1 4)))) + (setf (f2cl-lib:fref tmp + ((f2cl-lib:fref jpiv + ((f2cl-lib:int-sub 4 i)) + ((1 4)))) + ((1 4))) + temp))))) + (setf (f2cl-lib:fref x-%data% (1 1) ((1 ldx) (1 *)) x-%offset%) + (f2cl-lib:fref tmp (1) ((1 4)))) + (setf (f2cl-lib:fref x-%data% (2 1) ((1 ldx) (1 *)) x-%offset%) + (f2cl-lib:fref tmp (2) ((1 4)))) + (setf (f2cl-lib:fref x-%data% (1 2) ((1 ldx) (1 *)) x-%offset%) + (f2cl-lib:fref tmp (3) ((1 4)))) + (setf (f2cl-lib:fref x-%data% (2 2) ((1 ldx) (1 *)) x-%offset%) + (f2cl-lib:fref tmp (4) ((1 4)))) + (setf xnorm + (max + (+ (abs (f2cl-lib:fref tmp (1) ((1 4)))) + (abs (f2cl-lib:fref tmp (3) ((1 4))))) + (+ (abs (f2cl-lib:fref tmp (2) ((1 4)))) + (abs (f2cl-lib:fref tmp (4) ((1 4))))))) + end_label + (return + (values nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + scale + nil + nil + xnorm + 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::dlasy2 + 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 (*)) + fixnum (array double-float (*)) + fixnum (double-float) + (array double-float (*)) fixnum + (double-float) fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::scale nil nil + fortran-to-lisp::xnorm fortran-to-lisp::info) + :calls '(fortran-to-lisp::dswap fortran-to-lisp::dcopy + fortran-to-lisp::idamax fortran-to-lisp::dlamch)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dnrm2 BLAS} +\pagehead{dnrm2}{dnrm2} +%\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 dnrm2 (n x incx) + (declare (type (array double-float (*)) x) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((x double-float x-%data% x-%offset%)) + (prog ((absxi 0.0) (norm 0.0) (scale 0.0) (ssq 0.0) (ix 0) (dnrm2 0.0)) + (declare (type fixnum ix) + (type (double-float) absxi norm scale ssq dnrm2)) + (cond + ((or (< n 1) (< incx 1)) + (setf norm zero)) + ((= n 1) + (setf norm (abs (f2cl-lib:fref x-%data% (1) ((1 *)) x-%offset%)))) + (t + (setf scale zero) + (setf ssq one) + (f2cl-lib:fdo (ix 1 (f2cl-lib:int-add ix incx)) + ((> ix + (f2cl-lib:int-add 1 + (f2cl-lib:int-mul + (f2cl-lib:int-add n + (f2cl-lib:int-sub + 1)) + incx))) + nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (ix) ((1 *))) zero) + (setf absxi + (abs + (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%))) + (cond + ((< scale absxi) + (setf ssq (+ one (* ssq (expt (/ scale absxi) 2)))) + (setf scale absxi)) + (t + (setf ssq (+ ssq (expt (/ absxi scale) 2))))))))) + (setf norm (* scale (f2cl-lib:fsqrt ssq))))) + (setf dnrm2 norm) + end_label + (return (values dnrm2 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::dnrm2 fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum (array double-float (*)) + fixnum) + :return-values '(nil nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dorg2r LAPACK} +\pagehead{dorg2r}{dorg2r} +%\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 dorg2r (m n k a lda tau work info) + (declare (type (array double-float (*)) work tau a) + (type fixnum info lda k 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) (j 0) (l 0)) + (declare (type fixnum i j l)) + (setf info 0) + (cond + ((< m 0) + (setf info -1)) + ((or (< n 0) (> n m)) + (setf info -2)) + ((or (< k 0) (> k n)) + (setf info -3)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info -5))) + (cond + ((/= info 0) + (xerbla "DORG2R" (f2cl-lib:int-sub info)) + (go end_label))) + (if (<= n 0) (go end_label)) + (f2cl-lib:fdo (j (f2cl-lib:int-add k 1) (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l m) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% (l j) ((1 lda) (1 *)) a-%offset%) + zero))) + (setf (f2cl-lib:fref a-%data% (j j) ((1 lda) (1 *)) a-%offset%) + one))) + (f2cl-lib:fdo (i k (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (cond + ((< i n) + (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))) + (if (< i m) + (dscal (f2cl-lib:int-sub m i) + (- (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%)) + (f2cl-lib:array-slice a + double-float + ((+ i 1) i) + ((1 lda) (1 *))) + 1)) + (setf (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) + (- one + (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% (l i) ((1 lda) (1 *)) a-%offset%) + zero))))) + 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::dorg2r + 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::dscal fortran-to-lisp::dlarf + fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dorgbr LAPACK} +\pagehead{dorgbr}{dorgbr} +%\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 dorgbr (vect m n k a lda tau work lwork info) + (declare (type (array double-float (*)) work tau a) + (type fixnum info lwork lda k n m) + (type (simple-array character (*)) vect)) + (f2cl-lib:with-multi-array-data + ((vect character vect-%data% vect-%offset%) + (a double-float a-%data% a-%offset%) + (tau double-float tau-%data% tau-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((i 0) (iinfo 0) (j 0) (lwkopt 0) (mn 0) (nb 0) (lquery nil) + (wantq nil)) + (declare (type fixnum i iinfo j lwkopt mn nb) + (type (member t nil) lquery wantq)) + (setf info 0) + (setf wantq (lsame vect "Q")) + (setf mn (min (the fixnum m) (the fixnum n))) + (setf lquery (coerce (= lwork -1) '(member t nil))) + (cond + ((and (not wantq) (not (lsame vect "P"))) + (setf info -1)) + ((< m 0) + (setf info -2)) + ((or (< n 0) + (and wantq + (or (> n m) + (< n + (min (the fixnum m) + (the fixnum k))))) + (and (not wantq) + (or (> m n) + (< m + (min (the fixnum n) + (the fixnum k)))))) + (setf info -3)) + ((< k 0) + (setf info -4)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info -6)) + ((and + (< lwork + (max (the fixnum 1) (the fixnum mn))) + (not lquery)) + (setf info -9))) + (cond + ((= info 0) + (cond + (wantq + (setf nb (ilaenv 1 "DORGQR" " " m n k -1))) + (t + (setf nb (ilaenv 1 "DORGLQ" " " m n k -1)))) + (setf lwkopt + (f2cl-lib:int-mul + (max (the fixnum 1) (the fixnum mn)) + nb)) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum lwkopt) 'double-float)))) +p (cond + ((/= info 0) + (xerbla "DORGBR" (f2cl-lib:int-sub info)) + (go end_label)) + (lquery + (go end_label))) + (cond + ((or (= m 0) (= n 0)) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum 1) 'double-float)) + (go end_label))) + (cond + (wantq + (cond + ((>= m k) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dorgqr m n k a lda tau work lwork iinfo) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7)) + (setf iinfo var-8))) + (t + (f2cl-lib:fdo (j m (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 2) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%) + zero) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 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 (f2cl-lib:int-sub j 1)) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf (f2cl-lib:fref a-%data% (1 1) ((1 lda) (1 *)) a-%offset%) + one) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i 1) + ((1 lda) (1 *)) + a-%offset%) + zero))) + (cond + ((> m 1) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dorgqr (f2cl-lib:int-sub m 1) (f2cl-lib:int-sub m 1) + (f2cl-lib:int-sub m 1) + (f2cl-lib:array-slice a + double-float + (2 2) + ((1 lda) (1 *))) + lda tau work lwork iinfo) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7)) + (setf iinfo var-8))))))) + (t + (cond + ((< k n) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dorglq m n k a lda tau work lwork iinfo) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7)) + (setf iinfo var-8))) + (t + (setf (f2cl-lib:fref a-%data% (1 1) ((1 lda) (1 *)) a-%offset%) + one) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i 1) + ((1 lda) (1 *)) + a-%offset%) + zero))) + (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 2) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-sub i 1) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%) + zero))) + (cond + ((> n 1) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dorglq (f2cl-lib:int-sub n 1) (f2cl-lib:int-sub n 1) + (f2cl-lib:int-sub n 1) + (f2cl-lib:array-slice a + double-float + (2 2) + ((1 lda) (1 *))) + lda tau work lwork iinfo) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7)) + (setf iinfo var-8)))))))) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum lwkopt) 'double-float)) + 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::dorgbr + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + 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 nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dorglq fortran-to-lisp::dorgqr + fortran-to-lisp::xerbla fortran-to-lisp::ilaenv + fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dorghr LAPACK} +\pagehead{dorghr}{dorghr} +%\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 dorghr (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 ((i 0) (iinfo 0) (j 0) (lwkopt 0) (nb 0) (nh 0) (lquery nil)) + (declare (type fixnum i iinfo j lwkopt nb nh) + (type (member t nil) lquery)) + (setf info 0) + (setf nh (f2cl-lib:int-sub ihi ilo)) + (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 nh))) + (not lquery)) + (setf info -8))) + (cond + ((= info 0) + (setf nb (ilaenv 1 "DORGQR" " " nh nh nh -1)) + (setf lwkopt + (f2cl-lib:int-mul + (max (the fixnum 1) (the fixnum nh)) + nb)) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum lwkopt) 'double-float)))) + (cond + ((/= info 0) + (xerbla "DORGHR" (f2cl-lib:int-sub info)) + (go end_label)) + (lquery + (go end_label))) + (cond + ((= n 0) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum 1) 'double-float)) + (go end_label))) + (f2cl-lib:fdo (j ihi (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j (f2cl-lib:int-add ilo 1)) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% (i j) ((1 lda) (1 *)) a-%offset%) + zero))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) (f2cl-lib:int-add i 1)) + ((> i ihi) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% (i j) ((1 lda) (1 *)) a-%offset%) + (f2cl-lib:fref a-%data% + (i (f2cl-lib:int-sub j 1)) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add ihi 1) (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% (i j) ((1 lda) (1 *)) a-%offset%) + zero))))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j ilo) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% (i j) ((1 lda) (1 *)) a-%offset%) + zero))) + (setf (f2cl-lib:fref a-%data% (j j) ((1 lda) (1 *)) a-%offset%) + one))) + (f2cl-lib:fdo (j (f2cl-lib:int-add ihi 1) (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% (i j) ((1 lda) (1 *)) a-%offset%) + zero))) + (setf (f2cl-lib:fref a-%data% (j j) ((1 lda) (1 *)) a-%offset%) + one))) + (cond + ((> nh 0) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8) + (dorgqr nh nh nh + (f2cl-lib:array-slice a + double-float + ((+ ilo 1) (f2cl-lib:int-add ilo 1)) + ((1 lda) (1 *))) + lda (f2cl-lib:array-slice tau double-float (ilo) ((1 *))) work + lwork iinfo) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)) + (setf iinfo var-8)))) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum lwkopt) '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::dorghr + 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::dorgqr fortran-to-lisp::xerbla + fortran-to-lisp::ilaenv)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dorgl2 LAPACK} +\pagehead{dorgl2}{dorgl2} +%\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 dorgl2 (m n k a lda tau work info) + (declare (type (array double-float (*)) work tau a) + (type fixnum info lda k 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) (j 0) (l 0)) + (declare (type fixnum i j l)) + (setf info 0) + (cond + ((< m 0) + (setf info -1)) + ((< n m) + (setf info -2)) + ((or (< k 0) (> k m)) + (setf info -3)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info -5))) + (cond + ((/= info 0) + (xerbla "DORGL2" (f2cl-lib:int-sub info)) + (go end_label))) + (if (<= m 0) (go end_label)) + (cond + ((< k m) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (l (f2cl-lib:int-add k 1) (f2cl-lib:int-add l 1)) + ((> l m) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%) + zero))) + (if (and (> j k) (<= j m)) + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + one)))))) + (f2cl-lib:fdo (i k (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (cond + ((< i n) + (cond + ((< i m) + (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))) + (dscal (f2cl-lib:int-sub n i) + (- (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))) + (setf (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) + (- one + (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% (i l) ((1 lda) (1 *)) a-%offset%) + zero))))) + 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::dorgl2 + 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::dscal fortran-to-lisp::dlarf + fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dorglq LAPACK} +\pagehead{dorglq}{dorglq} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dorglq (m n k a lda tau work lwork info) + (declare (type (array double-float (*)) work tau a) + (type fixnum info lwork lda k 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) (j 0) (ki 0) (kk 0) (l 0) + (ldwork 0) (lwkopt 0) (nb 0) (nbmin 0) (nx 0) (lquery nil)) + (declare (type fixnum i ib iinfo iws j ki kk l ldwork + lwkopt nb nbmin nx) + (type (member t nil) lquery)) + (setf info 0) + (setf nb (ilaenv 1 "DORGLQ" " " m n k -1)) + (setf lwkopt + (f2cl-lib:int-mul + (max (the fixnum 1) (the fixnum 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 m) + (setf info -2)) + ((or (< k 0) (> k m)) + (setf info -3)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info -5)) + ((and + (< lwork (max (the fixnum 1) (the fixnum m))) + (not lquery)) + (setf info -8))) + (cond + ((/= info 0) + (xerbla "DORGLQ" (f2cl-lib:int-sub info)) + (go end_label)) + (lquery + (go end_label))) + (cond + ((<= m 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 "DORGLQ" " " m n k -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 "DORGLQ" " " m n k -1)))))))))) + (cond + ((and (>= nb nbmin) (< nb k) (< nx k)) + (setf ki (* (the fixnum (truncate (- k nx 1) nb)) nb)) + (setf kk + (min (the fixnum k) + (the fixnum (f2cl-lib:int-add ki nb)))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j kk) nil) + (tagbody + (f2cl-lib:fdo (i (f2cl-lib:int-add kk 1) (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + zero)))))) + (t + (setf kk 0))) + (if (< kk m) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dorgl2 (f2cl-lib:int-sub m kk) (f2cl-lib:int-sub n kk) + (f2cl-lib:int-sub k kk) + (f2cl-lib:array-slice a + double-float + ((+ kk 1) (f2cl-lib:int-add kk 1)) + ((1 lda) (1 *))) + lda (f2cl-lib:array-slice tau double-float ((+ kk 1)) ((1 *))) + work iinfo) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6)) + (setf iinfo var-7))) + (cond + ((> kk 0) + (f2cl-lib:fdo (i (f2cl-lib:int-add ki 1) + (f2cl-lib:int-add i (f2cl-lib:int-sub nb))) + ((> i 1) nil) + (tagbody + (setf ib + (min (the fixnum nb) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-sub k i) 1)))) + (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" "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))) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dorgl2 ib (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 iinfo) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6)) + (setf iinfo var-7)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + nil) + (tagbody + (f2cl-lib:fdo (l i (f2cl-lib:int-add l 1)) + ((> l + (f2cl-lib:int-add i + ib + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%) + zero))))))))) + (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::dorglq + 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::dlarfb fortran-to-lisp::dlarft + fortran-to-lisp::dorgl2 fortran-to-lisp::xerbla + fortran-to-lisp::ilaenv)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dorgqr LAPACK} +\pagehead{dorgqr}{dorgqr} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dorgqr (m n k a lda tau work lwork info) + (declare (type (array double-float (*)) work tau a) + (type fixnum info lwork lda k 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) (j 0) (ki 0) (kk 0) (l 0) + (ldwork 0) (lwkopt 0) (nb 0) (nbmin 0) (nx 0) (lquery nil)) + (declare (type fixnum i ib iinfo iws j ki kk l ldwork + lwkopt nb nbmin nx) + (type (member t nil) lquery)) + (setf info 0) + (setf nb (ilaenv 1 "DORGQR" " " m n k -1)) + (setf lwkopt + (f2cl-lib:int-mul + (max (the fixnum 1) (the fixnum 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)) + ((or (< n 0) (> n m)) + (setf info -2)) + ((or (< k 0) (> k n)) + (setf info -3)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info -5)) + ((and + (< lwork (max (the fixnum 1) (the fixnum n))) + (not lquery)) + (setf info -8))) + (cond + ((/= info 0) + (xerbla "DORGQR" (f2cl-lib:int-sub info)) + (go end_label)) + (lquery + (go end_label))) + (cond + ((<= n 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 "DORGQR" " " m n k -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 "DORGQR" " " m n k -1)))))))))) + (cond + ((and (>= nb nbmin) (< nb k) (< nx k)) + (setf ki (* (the fixnum (truncate (- k nx 1) nb)) nb)) + (setf kk + (min (the fixnum k) + (the fixnum (f2cl-lib:int-add ki nb)))) + (f2cl-lib:fdo (j (f2cl-lib:int-add kk 1) (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i kk) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + zero)))))) + (t + (setf kk 0))) + (if (< kk n) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dorg2r (f2cl-lib:int-sub m kk) (f2cl-lib:int-sub n kk) + (f2cl-lib:int-sub k kk) + (f2cl-lib:array-slice a + double-float + ((+ kk 1) (f2cl-lib:int-add kk 1)) + ((1 lda) (1 *))) + lda (f2cl-lib:array-slice tau double-float ((+ kk 1)) ((1 *))) + work iinfo) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6)) + (setf iinfo var-7))) + (cond + ((> kk 0) + (f2cl-lib:fdo (i (f2cl-lib:int-add ki 1) + (f2cl-lib:int-add i (f2cl-lib:int-sub nb))) + ((> i 1) nil) + (tagbody + (setf ib + (min (the fixnum nb) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-sub k i) 1)))) + (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" "No 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))) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7) + (dorg2r (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) ib 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 var-6)) + (setf iinfo var-7)) + (f2cl-lib:fdo (j i (f2cl-lib:int-add j 1)) + ((> j + (f2cl-lib:int-add i ib (f2cl-lib:int-sub 1))) + nil) + (tagbody + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%) + zero))))))))) + (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::dorgqr + 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::dlarfb fortran-to-lisp::dlarft + fortran-to-lisp::dorg2r fortran-to-lisp::xerbla + fortran-to-lisp::ilaenv)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dorm2r LAPACK} +\pagehead{dorm2r}{dorm2r} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0)) + (declare (type (double-float 1.0 1.0) one)) + (defun dorm2r (side trans m n k a lda tau c ldc work info) + (declare (type (array double-float (*)) work c tau a) + (type fixnum info ldc lda k n m) + (type (simple-array character (*)) trans side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (trans character trans-%data% trans-%offset%) + (a double-float a-%data% a-%offset%) + (tau double-float tau-%data% tau-%offset%) + (c double-float c-%data% c-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((aii 0.0) (i 0) (i1 0) (i2 0) (i3 0) (ic 0) (jc 0) (mi 0) (ni 0) + (nq 0) (left nil) (notran nil)) + (declare (type (double-float) aii) + (type fixnum i i1 i2 i3 ic jc mi ni nq) + (type (member t nil) left notran)) + (setf info 0) + (setf left (lsame side "L")) + (setf notran (lsame trans "N")) + (cond + (left + (setf nq m)) + (t + (setf nq n))) + (cond + ((and (not left) (not (lsame side "R"))) + (setf info -1)) + ((and (not notran) (not (lsame trans "T"))) + (setf info -2)) + ((< m 0) + (setf info -3)) + ((< n 0) + (setf info -4)) + ((or (< k 0) (> k nq)) + (setf info -5)) + ((< lda (max (the fixnum 1) (the fixnum nq))) + (setf info -7)) + ((< ldc (max (the fixnum 1) (the fixnum m))) + (setf info -10))) + (cond + ((/= info 0) + (xerbla "DORM2R" (f2cl-lib:int-sub info)) + (go end_label))) + (if (or (= m 0) (= n 0) (= k 0)) (go end_label)) + (cond + ((or (and left (not notran)) (and (not left) notran)) + (setf i1 1) + (setf i2 k) + (setf i3 1)) + (t + (setf i1 k) + (setf i2 1) + (setf i3 -1))) + (cond + (left + (setf ni n) + (setf jc 1)) + (t + (setf mi m) + (setf ic 1))) + (f2cl-lib:fdo (i i1 (f2cl-lib:int-add i i3)) + ((> i i2) nil) + (tagbody + (cond + (left + (setf mi (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1)) + (setf ic i)) + (t + (setf ni (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1)) + (setf jc i))) + (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 side mi ni + (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 c double-float (ic jc) ((1 ldc) (1 *))) ldc + 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 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::dorm2r + 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 (*)) fixnum + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlarf fortran-to-lisp::xerbla + fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dormbr LAPACK} +\pagehead{dormbr}{dormbr} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun dormbr (vect side trans m n k a lda tau c ldc work lwork info) + (declare (type (array double-float (*)) work c tau a) + (type fixnum info lwork ldc lda k n m) + (type (simple-array character (*)) trans side vect)) + (f2cl-lib:with-multi-array-data + ((vect character vect-%data% vect-%offset%) + (side character side-%data% side-%offset%) + (trans character trans-%data% trans-%offset%) + (a double-float a-%data% a-%offset%) + (tau double-float tau-%data% tau-%offset%) + (c double-float c-%data% c-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((i1 0) (i2 0) (iinfo 0) (lwkopt 0) (mi 0) (nb 0) (ni 0) (nq 0) + (nw 0) + (transt + (make-array '(1) :element-type 'character :initial-element #\ )) + (applyq nil) (left nil) (lquery nil) (notran nil)) + (declare (type (member t nil) notran lquery left applyq) + (type (simple-array character (1)) transt) + (type fixnum nw nq ni nb mi lwkopt iinfo i2 i1)) + (setf info 0) + (setf applyq (lsame vect "Q")) + (setf left (lsame side "L")) + (setf notran (lsame trans "N")) + (setf lquery (coerce (= lwork -1) '(member t nil))) + (cond + (left + (setf nq m) + (setf nw n)) + (t + (setf nq n) + (setf nw m))) + (cond + ((and (not applyq) (not (lsame vect "P"))) + (setf info -1)) + ((and (not left) (not (lsame side "R"))) + (setf info -2)) + ((and (not notran) (not (lsame trans "T"))) + (setf info -3)) + ((< m 0) + (setf info -4)) + ((< n 0) + (setf info -5)) + ((< k 0) + (setf info -6)) + ((or + (and applyq + (< lda + (max (the fixnum 1) (the fixnum nq)))) + (and (not applyq) + (< lda + (max (the fixnum 1) + (the fixnum + (min (the fixnum nq) + (the fixnum k))))))) + (setf info -8)) + ((< ldc (max (the fixnum 1) (the fixnum m))) + (setf info -11)) + ((and + (< lwork (max (the fixnum 1) (the fixnum nw))) + (not lquery)) + (setf info -13))) + (cond + ((= info 0) + (cond + (applyq + (cond + (left + (setf nb + (ilaenv 1 "DORMQR" (f2cl-lib:f2cl-// side trans) + (f2cl-lib:int-sub m 1) n (f2cl-lib:int-sub m 1) -1))) + (t + (setf nb + (ilaenv 1 "DORMQR" (f2cl-lib:f2cl-// side trans) m + (f2cl-lib:int-sub n 1) (f2cl-lib:int-sub n 1) -1))))) + (t + (cond + (left + (setf nb + (ilaenv 1 "DORMLQ" (f2cl-lib:f2cl-// side trans) + (f2cl-lib:int-sub m 1) n (f2cl-lib:int-sub m 1) -1))) + (t + (setf nb + (ilaenv 1 "DORMLQ" (f2cl-lib:f2cl-// side trans) m + (f2cl-lib:int-sub n 1) (f2cl-lib:int-sub n 1) -1)))))) + (setf lwkopt + (f2cl-lib:int-mul + (max (the fixnum 1) (the fixnum nw)) + nb)) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum lwkopt) 'double-float)))) + (cond + ((/= info 0) + (xerbla "DORMBR" (f2cl-lib:int-sub info)) + (go end_label)) + (lquery + (go end_label))) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum 1) 'double-float)) + (if (or (= m 0) (= n 0)) (go end_label)) + (cond + (applyq + (cond + ((>= nq k) + (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) + (dormqr side trans m n k a lda tau c ldc work lwork iinfo) + (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)) + (setf iinfo var-12))) + ((> nq 1) + (cond + (left + (setf mi (f2cl-lib:int-sub m 1)) + (setf ni n) + (setf i1 2) + (setf i2 1)) + (t + (setf mi m) + (setf ni (f2cl-lib:int-sub n 1)) + (setf i1 1) + (setf i2 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 var-12) + (dormqr side trans mi ni (f2cl-lib:int-sub nq 1) + (f2cl-lib:array-slice a double-float (2 1) ((1 lda) (1 *))) + lda tau + (f2cl-lib:array-slice c double-float (i1 i2) ((1 ldc) (1 *))) + ldc work lwork iinfo) + (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)) + (setf iinfo var-12))))) + (t + (cond + (notran + (f2cl-lib:f2cl-set-string transt "T" (string 1))) + (t + (f2cl-lib:f2cl-set-string transt "N" (string 1)))) + (cond + ((> nq k) + (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) + (dormlq side transt m n k a lda tau c ldc work lwork iinfo) + (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)) + (setf iinfo var-12))) + ((> nq 1) + (cond + (left + (setf mi (f2cl-lib:int-sub m 1)) + (setf ni n) + (setf i1 2) + (setf i2 1)) + (t + (setf mi m) + (setf ni (f2cl-lib:int-sub n 1)) + (setf i1 1) + (setf i2 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 var-12) + (dormlq side transt mi ni (f2cl-lib:int-sub nq 1) + (f2cl-lib:array-slice a double-float (1 2) ((1 lda) (1 *))) + lda tau + (f2cl-lib:array-slice c double-float (i1 i2) ((1 ldc) (1 *))) + ldc work lwork iinfo) + (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)) + (setf iinfo var-12)))))) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum lwkopt) '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::dormbr + 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)) + fixnum fixnum + fixnum (array double-float (*)) + fixnum (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::dormlq fortran-to-lisp::dormqr + fortran-to-lisp::xerbla fortran-to-lisp::ilaenv + fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dorml2 LAPACK} +\pagehead{dorml2}{dorml2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0)) + (declare (type (double-float 1.0 1.0) one)) + (defun dorml2 (side trans m n k a lda tau c ldc work info) + (declare (type (array double-float (*)) work c tau a) + (type fixnum info ldc lda k n m) + (type (simple-array character (*)) trans side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (trans character trans-%data% trans-%offset%) + (a double-float a-%data% a-%offset%) + (tau double-float tau-%data% tau-%offset%) + (c double-float c-%data% c-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((aii 0.0) (i 0) (i1 0) (i2 0) (i3 0) (ic 0) (jc 0) (mi 0) (ni 0) + (nq 0) (left nil) (notran nil)) + (declare (type (double-float) aii) + (type fixnum i i1 i2 i3 ic jc mi ni nq) + (type (member t nil) left notran)) + (setf info 0) + (setf left (lsame side "L")) + (setf notran (lsame trans "N")) + (cond + (left + (setf nq m)) + (t + (setf nq n))) + (cond + ((and (not left) (not (lsame side "R"))) + (setf info -1)) + ((and (not notran) (not (lsame trans "T"))) + (setf info -2)) + ((< m 0) + (setf info -3)) + ((< n 0) + (setf info -4)) + ((or (< k 0) (> k nq)) + (setf info -5)) + ((< lda (max (the fixnum 1) (the fixnum k))) + (setf info -7)) + ((< ldc (max (the fixnum 1) (the fixnum m))) + (setf info -10))) + (cond + ((/= info 0) + (xerbla "DORML2" (f2cl-lib:int-sub info)) + (go end_label))) + (if (or (= m 0) (= n 0) (= k 0)) (go end_label)) + (cond + ((or (and left notran) (and (not left) (not notran))) + (setf i1 1) + (setf i2 k) + (setf i3 1)) + (t + (setf i1 k) + (setf i2 1) + (setf i3 -1))) + (cond + (left + (setf ni n) + (setf jc 1)) + (t + (setf mi m) + (setf ic 1))) + (f2cl-lib:fdo (i i1 (f2cl-lib:int-add i i3)) + ((> i i2) nil) + (tagbody + (cond + (left + (setf mi (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1)) + (setf ic i)) + (t + (setf ni (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1)) + (setf jc i))) + (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 side mi ni + (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 c double-float (ic jc) ((1 ldc) (1 *))) ldc + 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 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::dorml2 + 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 (*)) fixnum + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlarf fortran-to-lisp::xerbla + fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dormlq LAPACK} +\pagehead{dormlq}{dormlq} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((nbmax 64) (ldt (+ nbmax 1))) + (declare (type (fixnum 64 64) nbmax) + (type fixnum ldt)) + (defun dormlq (side trans m n k a lda tau c ldc work lwork info) + (declare (type (array double-float (*)) work c tau a) + (type fixnum info lwork ldc lda k n m) + (type (simple-array character (*)) trans side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (trans character trans-%data% trans-%offset%) + (a double-float a-%data% a-%offset%) + (tau double-float tau-%data% tau-%offset%) + (c double-float c-%data% c-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((i 0) (i1 0) (i2 0) (i3 0) (ib 0) (ic 0) (iinfo 0) (iws 0) (jc 0) + (ldwork 0) (lwkopt 0) (mi 0) (nb 0) (nbmin 0) (ni 0) (nq 0) (nw 0) + (transt + (make-array '(1) :element-type 'character :initial-element #\ )) + (left nil) (lquery nil) (notran nil) + (t$ + (make-array (the fixnum (reduce #'* (list ldt nbmax))) + :element-type 'double-float))) + (declare (type (array double-float (*)) t$) + (type fixnum i i1 i2 i3 ib ic iinfo iws jc ldwork + lwkopt mi nb nbmin ni nq nw) + (type (simple-array character (1)) transt) + (type (member t nil) left lquery notran)) + (setf info 0) + (setf left (lsame side "L")) + (setf notran (lsame trans "N")) + (setf lquery (coerce (= lwork -1) '(member t nil))) + (cond + (left + (setf nq m) + (setf nw n)) + (t + (setf nq n) + (setf nw m))) + (cond + ((and (not left) (not (lsame side "R"))) + (setf info -1)) + ((and (not notran) (not (lsame trans "T"))) + (setf info -2)) + ((< m 0) + (setf info -3)) + ((< n 0) + (setf info -4)) + ((or (< k 0) (> k nq)) + (setf info -5)) + ((< lda (max (the fixnum 1) (the fixnum k))) + (setf info -7)) + ((< ldc (max (the fixnum 1) (the fixnum m))) + (setf info -10)) + ((and + (< lwork + (max (the fixnum 1) (the fixnum nw))) + (not lquery)) + (setf info -12))) + (cond + ((= info 0) + (setf nb + (min (the fixnum nbmax) + (the fixnum + (ilaenv 1 "DORMLQ" (f2cl-lib:f2cl-// side trans) m + n k -1)))) + (setf lwkopt + (f2cl-lib:int-mul + (max (the fixnum 1) (the fixnum nw)) + nb)) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum lwkopt) 'double-float)))) + (cond + ((/= info 0) + (xerbla "DORMLQ" (f2cl-lib:int-sub info)) + (go end_label)) + (lquery + (go end_label))) + (cond + ((or (= m 0) (= n 0) (= 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 ldwork nw) + (cond + ((and (> nb 1) (< nb k)) + (setf iws (f2cl-lib:int-mul nw nb)) + (cond + ((< lwork iws) + (setf nb (the fixnum (truncate lwork ldwork))) + (setf nbmin + (max (the fixnum 2) + (the fixnum + (ilaenv 2 "DORMLQ" + (f2cl-lib:f2cl-// side trans) m n k -1))))))) + (t + (setf iws nw))) + (cond + ((or (< nb nbmin) (>= nb k)) + (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) + (dorml2 side trans m n k a lda tau c ldc work iinfo) + (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 iinfo var-11))) + (t + (cond + ((or (and left notran) (and (not left) (not notran))) + (setf i1 1) + (setf i2 k) + (setf i3 nb)) + (t + (setf i1 + (+ (* (the fixnum (truncate (- k 1) nb)) nb) + 1)) + (setf i2 1) + (setf i3 (f2cl-lib:int-sub nb)))) + (cond + (left + (setf ni n) + (setf jc 1)) + (t + (setf mi m) + (setf ic 1))) + (cond + (notran + (f2cl-lib:f2cl-set-string transt "T" (string 1))) + (t + (f2cl-lib:f2cl-set-string transt "N" (string 1)))) + (f2cl-lib:fdo (i i1 (f2cl-lib:int-add i i3)) + ((> i i2) nil) + (tagbody + (setf ib + (min (the fixnum nb) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-sub k i) 1)))) + (dlarft "Forward" "Rowwise" + (f2cl-lib:int-add (f2cl-lib:int-sub nq 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 *))) t$ ldt) + (cond + (left + (setf mi (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1)) + (setf ic i)) + (t + (setf ni (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1)) + (setf jc i))) + (dlarfb side transt "Forward" "Rowwise" mi ni ib + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) lda + t$ ldt + (f2cl-lib:array-slice c double-float (ic jc) ((1 ldc) (1 *))) + ldc work ldwork))))) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum lwkopt) 'double-float)) + end_label + (return + (values 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::dormlq + 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 (*)) fixnum + (array double-float (*)) fixnum + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlarfb fortran-to-lisp::dlarft + fortran-to-lisp::dorml2 fortran-to-lisp::xerbla + fortran-to-lisp::ilaenv fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dormqr LAPACK} +\pagehead{dormqr}{dormqr} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((nbmax 64) (ldt (+ nbmax 1))) + (declare (type (fixnum 64 64) nbmax) + (type fixnum ldt)) + (defun dormqr (side trans m n k a lda tau c ldc work lwork info) + (declare (type (array double-float (*)) work c tau a) + (type fixnum info lwork ldc lda k n m) + (type (simple-array character (*)) trans side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (trans character trans-%data% trans-%offset%) + (a double-float a-%data% a-%offset%) + (tau double-float tau-%data% tau-%offset%) + (c double-float c-%data% c-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((i 0) (i1 0) (i2 0) (i3 0) (ib 0) (ic 0) (iinfo 0) (iws 0) (jc 0) + (ldwork 0) (lwkopt 0) (mi 0) (nb 0) (nbmin 0) (ni 0) (nq 0) (nw 0) + (left nil) (lquery nil) (notran nil) + (t$ + (make-array (the fixnum (reduce #'* (list ldt nbmax))) + :element-type 'double-float))) + (declare (type (array double-float (*)) t$) + (type fixnum i i1 i2 i3 ib ic iinfo iws jc ldwork + lwkopt mi nb nbmin ni nq nw) + (type (member t nil) left lquery notran)) + (setf info 0) + (setf left (lsame side "L")) + (setf notran (lsame trans "N")) + (setf lquery (coerce (= lwork -1) '(member t nil))) + (cond + (left + (setf nq m) + (setf nw n)) + (t + (setf nq n) + (setf nw m))) + (cond + ((and (not left) (not (lsame side "R"))) + (setf info -1)) + ((and (not notran) (not (lsame trans "T"))) + (setf info -2)) + ((< m 0) + (setf info -3)) + ((< n 0) + (setf info -4)) + ((or (< k 0) (> k nq)) + (setf info -5)) + ((< lda (max (the fixnum 1) (the fixnum nq))) + (setf info -7)) + ((< ldc (max (the fixnum 1) (the fixnum m))) + (setf info -10)) + ((and + (< lwork + (max (the fixnum 1) (the fixnum nw))) + (not lquery)) + (setf info -12))) + (cond + ((= info 0) + (setf nb + (min (the fixnum nbmax) + (the fixnum + (ilaenv 1 "DORMQR" (f2cl-lib:f2cl-// side trans) m + n k -1)))) + (setf lwkopt + (f2cl-lib:int-mul + (max (the fixnum 1) (the fixnum nw)) + nb)) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum lwkopt) 'double-float)))) + (cond + ((/= info 0) + (xerbla "DORMQR" (f2cl-lib:int-sub info)) + (go end_label)) + (lquery + (go end_label))) + (cond + ((or (= m 0) (= n 0) (= 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 ldwork nw) + (cond + ((and (> nb 1) (< nb k)) + (setf iws (f2cl-lib:int-mul nw nb)) + (cond + ((< lwork iws) + (setf nb (the fixnum (truncate lwork ldwork))) + (setf nbmin + (max (the fixnum 2) + (the fixnum + (ilaenv 2 "DORMQR" + (f2cl-lib:f2cl-// side trans) m n k -1))))))) + (t + (setf iws nw))) + (cond + ((or (< nb nbmin) (>= nb k)) + (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) + (dorm2r side trans m n k a lda tau c ldc work iinfo) + (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 iinfo var-11))) + (t + (cond + ((or (and left (not notran)) (and (not left) notran)) + (setf i1 1) + (setf i2 k) + (setf i3 nb)) + (t + (setf i1 + (+ (* (the fixnum (truncate (- k 1) nb)) nb) + 1)) + (setf i2 1) + (setf i3 (f2cl-lib:int-sub nb)))) + (cond + (left + (setf ni n) + (setf jc 1)) + (t + (setf mi m) + (setf ic 1))) + (f2cl-lib:fdo (i i1 (f2cl-lib:int-add i i3)) + ((> i i2) nil) + (tagbody + (setf ib + (min (the fixnum nb) + (the fixnum + (f2cl-lib:int-add (f2cl-lib:int-sub k i) 1)))) + (dlarft "Forward" "Columnwise" + (f2cl-lib:int-add (f2cl-lib:int-sub nq 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 *))) t$ ldt) + (cond + (left + (setf mi (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1)) + (setf ic i)) + (t + (setf ni (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1)) + (setf jc i))) + (dlarfb side trans "Forward" "Columnwise" mi ni ib + (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *))) lda + t$ ldt + (f2cl-lib:array-slice c double-float (ic jc) ((1 ldc) (1 *))) + ldc work ldwork))))) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) + (coerce (the fixnum lwkopt) 'double-float)) + end_label + (return + (values 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::dormqr + 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 (*)) fixnum + (array double-float (*)) fixnum + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlarfb fortran-to-lisp::dlarft + fortran-to-lisp::dorm2r fortran-to-lisp::xerbla + fortran-to-lisp::ilaenv fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{drotg BLAS} +\pagehead{drotg}{drotg} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +Double precision. Computes plane rotation. +Arguments are: +\begin{itemize} +\item da - double-float +\item db - double-float +\item c - double-float +\item s - double-float +\end{itemize} +Returns multiple values where: +\begin{itemize} +\item 1 da - double-float +\item 2 db - double-float +\item 3 c - double-float +\item 4 s - double-float +\end{itemize} + +<>= +(defun drotg (da db c s) + (declare (type (double-float) s c db da)) + (prog ((roe 0.0) (scale 0.0) (r 0.0) (z 0.0)) + (declare (type (double-float) z r scale roe)) + (setf roe db) + (when (> (the double-float (abs da)) (the double-float (abs db))) + (setf roe da)) + (setf scale (+ (the double-float (abs da)) (the double-float (abs db)))) + (if (/= scale 0.0) (go label10)) + (setf c 1.0) + (setf s 0.0) + (setf r 0.0) + (setf z 0.0) + (go label20) + label10 + (setf r + (* scale (f2cl-lib:dsqrt (+ (expt (/ da scale) 2) (expt (/ db scale) 2))))) + (setf r (* (f2cl-lib:dsign 1.0 roe) r)) + (setf c (/ da r)) + (setf s (/ db r)) + (setf z 1.0) + (when (> (the double-float (abs da)) (the double-float (abs db))) + (setf z s)) + (if (and (>= (the double-float (abs db)) (the double-float (abs da))) + (/= c 0.0)) + (setf z (/ 1.0 c))) + label20 + (setf da r) + (setf db z) + (return (values da db c s)))) + +;(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::drotg fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((double-float) (double-float) (double-float) +; (double-float)) +; :return-values '(fortran-to-lisp::da fortran-to-lisp::db +; fortran-to-lisp::c fortran-to-lisp::s) +; :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{drot BLAS} +\pagehead{drot}{drot} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun drot (n dx incx dy incy c s) + (declare (type (double-float) s c) + (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) (dtemp 0.0)) + (declare (type (double-float) dtemp) (type fixnum 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 dtemp + (+ (* c (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%)) + (* s (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%)))) + (setf (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%) + (- (* c (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%)) + (* s (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%)))) + (setf (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%) dtemp) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (go end_label) + label20 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf dtemp + (+ (* c (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)) + (* s (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%)))) + (setf (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%) + (- (* c (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%)) + (* s (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)))) + (setf (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) dtemp))) + 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::drot fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum (array double-float (*)) + fixnum (array double-float (*)) + fixnum (double-float) + (double-float)) + :return-values '(nil nil nil nil nil nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dsbmv BLAS} +\pagehead{dsbmv}{dsbmv} +%\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 dsbmv (uplo n k 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 k n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%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) (kplus1 0) (kx 0) + (ky 0) (l 0) (temp1 0.0) (temp2 0.0)) + (declare (type fixnum i info ix iy j jx jy kplus1 kx ky l) + (type (double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((< k 0) + (setf info 3)) + ((< lda (f2cl-lib:int-add k 1)) + (setf info 6)) + ((= incx 0) + (setf info 8)) + ((= incy 0) + (setf info 11))) + (cond + ((/= info 0) + (xerbla "DSBMV " info) + (go end_label))) + (if (or (= n 0) (and (= alpha zero) (= beta one))) (go end_label)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incy))))) + (cond + ((/= beta one) + (cond + ((= incy 1) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) 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 n) 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 n) 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 n) 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 uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf ix kx) + (setf iy ky) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l 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 iy (f2cl-lib:int-add iy incy)))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (cond + ((> j k) + (setf kx (f2cl-lib:int-add kx incx)) + (setf ky (f2cl-lib:int-add ky incy))))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf l (f2cl-lib:int-sub 1 j)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* alpha temp2)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf l (f2cl-lib:int-sub 1 j)) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)) + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (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::dsbmv 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{dscal BLAS} +\pagehead{dscal}{dscal} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun dscal (n da dx incx) + (declare (type (array double-float (*)) dx) + (type (double-float) da) + (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)) + (declare (type fixnum nincx mp1 m i)) + (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 (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) + (* da (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%))))) + (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 (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) + (* da (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%))))) + (if (< n 5) (go end_label)) + 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 (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) + (* da (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%))) + (setf (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + dx-%offset%) + (* da + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + dx-%offset%))) + (setf (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 2)) + ((1 *)) + dx-%offset%) + (* da + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 2)) + ((1 *)) + dx-%offset%))) + (setf (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 3)) + ((1 *)) + dx-%offset%) + (* da + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 3)) + ((1 *)) + dx-%offset%))) + (setf (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 4)) + ((1 *)) + dx-%offset%) + (* da + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 4)) + ((1 *)) + dx-%offset%))))) + end_label + (return (values 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::dscal fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum (double-float) + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dspmv BLAS} +\pagehead{dspmv}{dspmv} +%\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 dspmv (uplo n alpha ap x incx beta y incy) + (declare (type (array double-float (*)) y x ap) + (type (double-float) beta alpha) + (type fixnum incy incx n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (ap double-float ap-%data% ap-%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) (kk 0) + (kx 0) (ky 0) (temp1 0.0) (temp2 0.0)) + (declare (type fixnum i info ix iy j jx jy k kk kx ky) + (type (double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 6)) + ((= incy 0) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "DSPMV " info) + (go end_label))) + (if (or (= n 0) (and (= alpha zero) (= beta one))) (go end_label)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incy))))) + (cond + ((/= beta one) + (cond + ((= incy 1) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) 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 n) 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 n) 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 n) 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 kk 1) + (cond + ((lsame uplo "U") + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf k kk) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) + (* alpha temp2))) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf ix kx) + (setf iy ky) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub 2))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-add kk 1)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* alpha temp2))) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) + (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub j))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)) + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1))))))))) + 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::dspmv fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum (double-float) + (array double-float (*)) (array double-float (*)) + fixnum (double-float) + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dspr2 BLAS} +\pagehead{dspr2}{dspr2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dspr2 (uplo n alpha x incx y incy ap) + (declare (type (array double-float (*)) ap y x) + (type (double-float) alpha) + (type fixnum incy incx n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (x double-float x-%data% x-%offset%) + (y double-float y-%data% y-%offset%) + (ap double-float ap-%data% ap-%offset%)) + (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (k 0) (kk 0) + (kx 0) (ky 0) (temp1 0.0) (temp2 0.0)) + (declare (type fixnum i info ix iy j jx jy k kk kx ky) + (type (double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 5)) + ((= incy 0) + (setf info 7))) + (cond + ((/= info 0) + (xerbla "DSPR2 " info) + (go end_label))) + (if (or (= n 0) (= alpha zero)) (go end_label)) + (cond + ((or (/= incx 1) (/= incy 1)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incy))))) + (setf jx kx) + (setf jy ky))) + (setf kk 1) + (cond + ((lsame uplo "U") + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) + (/= (f2cl-lib:fref y (j) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + (setf k kk) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + temp2))) + (setf k (f2cl-lib:int-add k 1)))))) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf ix kx) + (setf iy ky) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + temp2))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) + (/= (f2cl-lib:fref y (j) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + (setf k kk) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + temp2))) + (setf k (f2cl-lib:int-add k 1)))))) + (setf kk + (f2cl-lib:int-add + (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) + 1))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub j))) + nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + temp2))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (setf kk + (f2cl-lib:int-add + (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) + 1)))))))) + end_label + (return (values 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::dspr2 fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum (double-float) + (array double-float (*)) fixnum + (array double-float (*)) fixnum + (array double-float (*))) + :return-values '(nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dspr BLAS} +\pagehead{dspr}{dspr} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dspr (uplo n alpha x incx ap) + (declare (type (array double-float (*)) ap x) + (type (double-float) alpha) + (type fixnum incx n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (x double-float x-%data% x-%offset%) + (ap double-float ap-%data% ap-%offset%)) + (prog ((i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0) (kk 0) (kx 0) (temp 0.0)) + (declare (type fixnum i info ix j jx k kk kx) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 5))) + (cond + ((/= info 0) + (xerbla "DSPR " info) + (go end_label))) + (if (or (= n 0) (= alpha zero)) (go end_label)) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (setf kk 1) + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + (setf k kk) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp))) + (setf k (f2cl-lib:int-add k 1)))))) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (setf jx kx) + (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 ix kx) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp))) + (setf ix (f2cl-lib:int-add ix incx)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + (setf k kk) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp))) + (setf k (f2cl-lib:int-add k 1)))))) + (setf kk + (f2cl-lib:int-add + (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) + 1))))) + (t + (setf jx kx) + (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 ix jx) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub j))) + nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp))) + (setf ix (f2cl-lib:int-add ix incx)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk + (f2cl-lib:int-add + (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) + 1)))))))) + end_label + (return (values 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::dspr fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum (double-float) + (array double-float (*)) fixnum + (array double-float (*))) + :return-values '(nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dswap BLAS} +\pagehead{dswap}{dswap} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun dswap (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)) + (declare (type (double-float) dtemp) + (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 dtemp (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%)) + (setf (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%) + (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%)) + (setf (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%) dtemp) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (go end_label) + label20 + (setf m (mod n 3)) + (if (= m 0) (go label40)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf dtemp (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)) + (setf (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) + (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%)) + (setf (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%) dtemp))) + (if (< n 3) (go end_label)) + label40 + (setf mp1 (f2cl-lib:int-add m 1)) + (f2cl-lib:fdo (i mp1 (f2cl-lib:int-add i 3)) + ((> i n) nil) + (tagbody + (setf dtemp (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)) + (setf (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) + (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%)) + (setf (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%) dtemp) + (setf dtemp + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + dx-%offset%)) + (setf (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%)) + (setf (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + dy-%offset%) + dtemp) + (setf dtemp + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 2)) + ((1 *)) + dx-%offset%)) + (setf (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%)) + (setf (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 2)) + ((1 *)) + dy-%offset%) + dtemp))) + 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::dswap 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{dsymm BLAS} +\pagehead{dsymm}{dsymm} +%\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 dsymm (side uplo m n 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 n m) + (type (simple-array character (*)) uplo side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (uplo character uplo-%data% uplo-%offset%) + (a double-float a-%data% a-%offset%) + (b double-float b-%data% b-%offset%) + (c double-float c-%data% c-%offset%)) + (prog ((temp1 0.0) (temp2 0.0) (i 0) (info 0) (j 0) (k 0) (nrowa 0) + (upper nil)) + (declare (type (double-float) temp1 temp2) + (type fixnum i info j k nrowa) + (type (member t nil) upper)) + (cond + ((lsame side "L") + (setf nrowa m)) + (t + (setf nrowa n))) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not (lsame side "L")) (not (lsame side "R"))) + (setf info 1)) + ((and (not upper) (not (lsame uplo "L"))) + (setf info 2)) + ((< m 0) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 7)) + ((< ldb$ (max (the fixnum 1) (the fixnum m))) + (setf info 9)) + ((< ldc (max (the fixnum 1) (the fixnum m))) + (setf info 12))) + (cond + ((/= info 0) + (xerbla "DSYMM " info) + (go end_label))) + (if (or (= m 0) (= n 0) (and (= alpha zero) (= 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 + ((lsame side "L") + (cond + (upper + (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 temp1 + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 zero) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add i + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* temp1 + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))) + (t + (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%)) + (* temp1 + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i m (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 zero) + (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) + (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* temp1 + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))) + (t + (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%)) + (* temp1 + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))) + (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%) + (* temp1 + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (t + (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%)) + (* temp1 + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + (upper + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%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%) + (* temp1 + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))) + (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + (upper + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%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%) + (* temp1 + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))))) + end_label + (return (values 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::dsymm fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + (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 nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dsymv BLAS} +\pagehead{dsymv}{dsymv} +%\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 dsymv (uplo 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) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%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) + (temp1 0.0) (temp2 0.0)) + (declare (type fixnum i info ix iy j jx jy kx ky) + (type (double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info 5)) + ((= incx 0) + (setf info 7)) + ((= incy 0) + (setf info 10))) + (cond + ((/= info 0) + (xerbla "DSYMV " info) + (go end_label))) + (if (or (= n 0) (and (= alpha zero) (= beta one))) (go end_label)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incy))))) + (cond + ((/= beta one) + (cond + ((= incy 1) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) 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 n) 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 n) 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 n) 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 uplo "U") + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (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% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf ix kx) + (setf iy ky) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (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 iy (f2cl-lib:int-add iy incy)))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (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% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* alpha temp2)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)) + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)))))))) + 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::dsymv fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + 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) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dsyr2k BLAS} +\pagehead{dsyr2k}{dsyr2k} +%\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 dsyr2k (uplo trans 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) + (type (simple-array character (*)) trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (a double-float a-%data% a-%offset%) + (b double-float b-%data% b-%offset%) + (c double-float c-%data% c-%offset%)) + (prog ((temp1 0.0) (temp2 0.0) (i 0) (info 0) (j 0) (l 0) (nrowa 0) + (upper nil)) + (declare (type (double-float) temp1 temp2) + (type fixnum i info j l nrowa) + (type (member t nil) upper)) + (cond + ((lsame trans "N") + (setf nrowa n)) + (t + (setf nrowa k))) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not upper) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((< n 0) + (setf info 3)) + ((< k 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 7)) + ((< ldb$ + (max (the fixnum 1) (the fixnum nrowa))) + (setf info 9)) + ((< ldc (max (the fixnum 1) (the fixnum n))) + (setf info 12))) + (cond + ((/= info 0) + (xerbla "DSYR2K" info) + (go end_label))) + (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) + (go end_label)) + (cond + ((= alpha zero) + (cond + (upper + (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 j) 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 j) 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%)))))))))) + (t + (cond + ((= beta zero) + (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 n) 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 j (f2cl-lib:int-add i 1)) + ((> i n) 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 + ((lsame trans "N") + (cond + (upper + (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 j) 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 j) 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 + ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) + (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) 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%) + (* + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%) + temp1) + (* + (f2cl-lib:fref b-%data% + (i l) + ((1 ldb$) (1 *)) + b-%offset%) + temp2)))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) 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 + ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) + (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) 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%) + (* + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%) + temp1) + (* + (f2cl-lib:fref b-%data% + (i l) + ((1 ldb$) (1 *)) + b-%offset%) + temp2)))))))))))))) + (t + (cond + (upper + (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 j) nil) + (tagbody + (setf temp1 zero) + (setf temp2 zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp1 + (+ temp1 + (* + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (l j) + ((1 ldb$) (1 *)) + b-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (l i) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp1) (* alpha temp2)))) + (t + (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%)) + (* alpha temp1) + (* alpha temp2)))))))))) + (t + (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 n) nil) + (tagbody + (setf temp1 zero) + (setf temp2 zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp1 + (+ temp1 + (* + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (l j) + ((1 ldb$) (1 *)) + b-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (l i) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp1) (* alpha temp2)))) + (t + (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%)) + (* alpha temp1) + (* alpha temp2))))))))))))) + end_label + (return (values 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::dsyr2k + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + (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 nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dsyr2 BLAS} +\pagehead{dsyr2}{dsyr2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dsyr2 (uplo 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) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (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) (iy 0) (j 0) (jx 0) (jy 0) (kx 0) (ky 0) + (temp1 0.0) (temp2 0.0)) + (declare (type fixnum i info ix iy j jx jy kx ky) + (type (double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (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 n))) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "DSYR2 " info) + (go end_label))) + (if (or (= n 0) (= alpha zero)) (go end_label)) + (cond + ((or (/= incx 1) (/= incy 1)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incy))))) + (setf jx kx) + (setf jy ky))) + (cond + ((lsame uplo "U") + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) + (/= (f2cl-lib:fref y (j) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) 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%) + temp1) + (* + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + temp2)))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf ix kx) + (setf iy ky) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) 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%) + temp1) + (* + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + temp2))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) + (/= (f2cl-lib:fref y (j) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) 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%) + temp1) + (* + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + temp2)))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) 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%) + temp1) + (* + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + temp2))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))))) + (setf jx (f2cl-lib:int-add jx 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::dsyr2 fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + 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 fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dsyrk BLAS} +\pagehead{dsyrk}{dsyrk} +%\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 dsyrk (uplo trans n k alpha a lda beta c ldc) + (declare (type (array double-float (*)) c a) + (type (double-float) beta alpha) + (type fixnum ldc lda k n) + (type (simple-array character (*)) trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (a double-float a-%data% a-%offset%) + (c double-float c-%data% c-%offset%)) + (prog ((temp 0.0) (i 0) (info 0) (j 0) (l 0) (nrowa 0) (upper nil)) + (declare (type (double-float) temp) + (type fixnum i info j l nrowa) + (type (member t nil) upper)) + (cond + ((lsame trans "N") + (setf nrowa n)) + (t + (setf nrowa k))) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not upper) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((< n 0) + (setf info 3)) + ((< k 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 7)) + ((< ldc (max (the fixnum 1) (the fixnum n))) + (setf info 10))) + (cond + ((/= info 0) + (xerbla "DSYRK " info) + (go end_label))) + (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) + (go end_label)) + (cond + ((= alpha zero) + (cond + (upper + (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 j) 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 j) 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%)))))))))) + (t + (cond + ((= beta zero) + (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 n) 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 j (f2cl-lib:int-add i 1)) + ((> i n) 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 + ((lsame trans "N") + (cond + (upper + (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 j) 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 j) 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 a (j l) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) 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 + (cond + ((= beta zero) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) 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 a (j l) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) 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 + (cond + (upper + (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 j) 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 a-%data% + (l j) + ((1 lda) (1 *)) + a-%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 + (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 n) 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 a-%data% + (l j) + ((1 lda) (1 *)) + a-%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)))))) + +(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::dsyrk fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + (simple-array character (1)) + fixnum fixnum + (double-float) (array double-float (*)) + fixnum (double-float) + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dsyr BLAS} +\pagehead{dsyr}{dsyr} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dsyr (uplo n alpha x incx a lda) + (declare (type (array double-float (*)) a x) + (type (double-float) alpha) + (type fixnum lda incx n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (x double-float x-%data% x-%offset%) + (a double-float a-%data% a-%offset%)) + (prog ((i 0) (info 0) (ix 0) (j 0) (jx 0) (kx 0) (temp 0.0)) + (declare (type fixnum i info ix j jx kx) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 5)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info 7))) + (cond + ((/= info 0) + (xerbla "DSYR " info) + (go end_label))) + (if (or (= n 0) (= alpha zero)) (go end_label)) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) 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)))))))))) + (t + (setf jx kx) + (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 ix kx) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) 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 jx (f2cl-lib:int-add jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) 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)))))))))) + (t + (setf jx kx) + (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 ix jx) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) 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 jx (f2cl-lib:int-add jx incx)))))))) + 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::dsyr fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum (double-float) + (array double-float (*)) fixnum + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dtbmv BLAS} +\pagehead{dtbmv}{dtbmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dtbmv (uplo trans diag n k a lda x incx) + (declare (type (array double-float (*)) x a) + (type fixnum incx lda k n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (a double-float a-%data% a-%offset%) + (x double-float x-%data% x-%offset%)) + (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (kplus1 0) (kx 0) + (l 0) (temp 0.0)) + (declare (type (member t nil) nounit) + (type fixnum i info ix j jx kplus1 kx l) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< k 0) + (setf info 5)) + ((< lda (f2cl-lib:int-add k 1)) + (setf info 7)) + ((= incx 0) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "DTBMV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%))))))))) + (t + (setf jx kx) + (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 + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (if (> j k) (setf kx (f2cl-lib:int-add kx incx)))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub 1 j)) + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%))))))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (setf l (f2cl-lib:int-sub 1 j)) + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf jx (f2cl-lib:int-sub jx incx)) + (if (>= (f2cl-lib:int-sub n j) k) + (setf kx (f2cl-lib:int-sub kx incx)))))))))) + (t + (cond + ((lsame uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub kplus1 j)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf kx (f2cl-lib:int-sub kx incx)) + (setf ix kx) + (setf l (f2cl-lib:int-sub kplus1 j)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub 1 j)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf kx (f2cl-lib:int-add kx incx)) + (setf ix kx) + (setf l (f2cl-lib:int-sub 1 j)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l 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 x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)))))))))) + 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::dtbmv 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)) + fixnum 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 fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dtbsv BLAS} +\pagehead{dtbsv}{dtbsv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dtbsv (uplo trans diag n k a lda x incx) + (declare (type (array double-float (*)) x a) + (type fixnum incx lda k n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (a double-float a-%data% a-%offset%) + (x double-float x-%data% x-%offset%)) + (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (kplus1 0) (kx 0) + (l 0) (temp 0.0)) + (declare (type (member t nil) nounit) + (type fixnum i info ix j jx kplus1 kx l) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< k 0) + (setf info 5)) + ((< lda (f2cl-lib:int-add k 1)) + (setf info 7)) + ((= incx 0) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "DTBSV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf l (f2cl-lib:int-sub kplus1 j)) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%))))))))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf kx (f2cl-lib:int-sub kx incx)) + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf ix kx) + (setf l (f2cl-lib:int-sub kplus1 j)) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))))) + (setf jx (f2cl-lib:int-sub jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf l (f2cl-lib:int-sub 1 j)) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%))))))))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf kx (f2cl-lib:int-add kx incx)) + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf ix kx) + (setf l (f2cl-lib:int-sub 1 j)) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))))) + (setf jx (f2cl-lib:int-add jx incx))))))))) + (t + (cond + ((lsame uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)) + (if (> j k) (setf kx (f2cl-lib:int-add kx incx)))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub 1 j)) + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (setf l (f2cl-lib:int-sub 1 j)) + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx)) + (if (>= (f2cl-lib:int-sub n j) k) + (setf kx (f2cl-lib:int-sub kx incx))))))))))) + 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::dtbsv 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)) + fixnum 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 fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dtpmv BLAS} +\pagehead{dtpmv}{dtpmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dtpmv (uplo trans diag n ap x incx) + (declare (type (array double-float (*)) x ap) + (type fixnum incx n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (ap double-float ap-%data% ap-%offset%) + (x double-float x-%data% x-%offset%)) + (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0) (kk 0) + (kx 0) (temp 0.0)) + (declare (type (member t nil) nounit) + (type fixnum i info ix j jx k kk kx) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((= incx 0) + (setf info 7))) + (cond + ((/= info 0) + (xerbla "DTPMV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (setf kk 1) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k kk) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)))))) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (setf jx kx) + (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 + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub + 2))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k kk) + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-sub k 1)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk n) + j)) + ((1 *)) + ap-%offset%)))))) + (setf kk + (f2cl-lib:int-sub kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (k kk + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub + (f2cl-lib:int-add + n + (f2cl-lib:int-sub + (f2cl-lib:int-add + j + 1)))))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk n) + j)) + ((1 *)) + ap-%offset%)))))) + (setf jx (f2cl-lib:int-sub jx incx)) + (setf kk + (f2cl-lib:int-sub kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))))))) + (t + (cond + ((lsame uplo "U") + (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-sub kk 1)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-sub k 1)))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp) + (setf kk (f2cl-lib:int-sub kk j))))) + (t + (setf jx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix jx) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (f2cl-lib:fdo (k + (f2cl-lib:int-add kk (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub j) + 1)) + nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx)) + (setf kk (f2cl-lib:int-sub kk j))))))) + (t + (setf kk 1) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-add kk 1)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix jx) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) + (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub j))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1))))))))))) + 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::dtpmv 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)) + fixnum (array double-float (*)) + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dtpsv BLAS} +\pagehead{dtpsv}{dtpsv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dtpsv (uplo trans diag n ap x incx) + (declare (type (array double-float (*)) x ap) + (type fixnum incx n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (ap double-float ap-%data% ap-%offset%) + (x double-float x-%data% x-%offset%)) + (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0) (kk 0) + (kx 0) (temp 0.0)) + (declare (type (member t nil) nounit) + (type fixnum i info ix j jx k kk kx) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((= incx 0) + (setf info 7))) + (cond + ((/= info 0) + (xerbla "DTPSV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k (f2cl-lib:int-sub kk 1)) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-sub k 1)))))) + (setf kk (f2cl-lib:int-sub kk j))))) + (t + (setf jx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix jx) + (f2cl-lib:fdo (k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub + j) + 1)) + nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))))))) + (setf jx (f2cl-lib:int-sub jx incx)) + (setf kk (f2cl-lib:int-sub kk j))))))) + (t + (setf kk 1) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k (f2cl-lib:int-add kk 1)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))))) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix jx) + (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) + (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub + j))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))))))) + (t + (cond + ((lsame uplo "U") + (setf kk 1) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k kk) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub 2))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k kk) + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-sub k 1)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk n) + j)) + ((1 *)) + ap-%offset%)))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp) + (setf kk + (f2cl-lib:int-sub kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (k kk + (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub + (f2cl-lib:int-add n + (f2cl-lib:int-sub + (f2cl-lib:int-add + j + 1)))))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk n) + j)) + ((1 *)) + ap-%offset%)))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx)) + (setf kk + (f2cl-lib:int-sub kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1))))))))))) + 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::dtpsv 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)) + fixnum (array double-float (*)) + (array double-float (*)) fixnum) + :return-values '(nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dtrevc LAPACK} +\pagehead{dtrevc}{dtrevc} +%\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 dtrevc (side howmny select n t$ ldt vl ldvl vr ldvr mm m work info) + (declare (type (array double-float (*)) work vr vl t$) + (type fixnum info m mm ldvr ldvl ldt n) + (type (array (member t nil) (*)) select) + (type (simple-array character (*)) howmny side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (howmny character howmny-%data% howmny-%offset%) + (select (member t nil) select-%data% select-%offset%) + (t$ double-float t$-%data% t$-%offset%) + (vl double-float vl-%data% vl-%offset%) + (vr double-float vr-%data% vr-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((x (make-array 4 :element-type 'double-float)) (beta 0.0) + (bignum 0.0) (emax 0.0) (ovfl 0.0) (rec 0.0) (remax 0.0) + (scale 0.0) (smin 0.0) (smlnum 0.0) (ulp 0.0) (unfl 0.0) + (vcrit 0.0) (vmax 0.0) (wi 0.0) (wr 0.0) (xnorm 0.0) (i 0) + (ierr 0) (ii 0) (ip 0) (is 0) (j 0) (j1 0) (j2 0) (jnxt 0) (k 0) + (ki 0) (n2 0) (allv nil) (bothv nil) (leftv nil) (over nil) + (pair nil) (rightv nil) (somev nil) (sqrt$ 0.0f0)) + (declare (type (single-float) sqrt$) + (type (array double-float (4)) x) + (type (double-float) beta bignum emax ovfl rec remax scale + smin smlnum ulp unfl vcrit vmax wi wr + xnorm) + (type fixnum i ierr ii ip is j j1 j2 jnxt k ki + n2) + (type (member t nil) allv bothv leftv over pair rightv + somev)) + (setf bothv (lsame side "B")) + (setf rightv (or (lsame side "R") bothv)) + (setf leftv (or (lsame side "L") bothv)) + (setf allv (lsame howmny "A")) + (setf over (lsame howmny "B")) + (setf somev (lsame howmny "S")) + (setf info 0) + (cond + ((and (not rightv) (not leftv)) + (setf info -1)) + ((and (not allv) (not over) (not somev)) + (setf info -2)) + ((< n 0) + (setf info -4)) + ((< ldt (max (the fixnum 1) (the fixnum n))) + (setf info -6)) + ((or (< ldvl 1) (and leftv (< ldvl n))) + (setf info -8)) + ((or (< ldvr 1) (and rightv (< ldvr n))) + (setf info -10)) + (t + (cond + (somev + (setf m 0) + (setf pair nil) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + (pair + (setf pair nil) + (setf (f2cl-lib:fref select-%data% + (j) + ((1 *)) + select-%offset%) + nil)) + (t + (cond + ((< j n) + (cond + ((= + (f2cl-lib:fref t$ + ((f2cl-lib:int-add j 1) j) + ((1 ldt) (1 *))) + zero) + (if + (f2cl-lib:fref select-%data% + (j) + ((1 *)) + select-%offset%) + (setf m (f2cl-lib:int-add m 1)))) + (t + (setf pair t) + (cond + ((or (f2cl-lib:fref select (j) ((1 *))) + (f2cl-lib:fref select + ((f2cl-lib:int-add j 1)) + ((1 *)))) + (setf (f2cl-lib:fref select-%data% + (j) + ((1 *)) + select-%offset%) + t) + (setf m (f2cl-lib:int-add m 2))))))) + (t + (if + (f2cl-lib:fref select-%data% + (n) + ((1 *)) + select-%offset%) + (setf m (f2cl-lib:int-add m 1)))))))))) + (t + (setf m n))) + (cond + ((< mm m) + (setf info -11))))) + (cond + ((/= info 0) + (xerbla "DTREVC" (f2cl-lib:int-sub info)) + (go end_label))) + (if (= n 0) (go end_label)) + (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 (/ n ulp))) + (setf bignum (/ (- one ulp) smlnum)) + (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) zero) + (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (j) ((1 *)) work-%offset%) zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (j) ((1 *)) work-%offset%) + (+ + (f2cl-lib:fref work-%data% (j) ((1 *)) work-%offset%) + (abs + (f2cl-lib:fref t$-%data% + (i j) + ((1 ldt) (1 *)) + t$-%offset%)))))))) + (setf n2 (f2cl-lib:int-mul 2 n)) + (cond + (rightv + (setf ip 0) + (setf is m) + (f2cl-lib:fdo (ki n (f2cl-lib:int-add ki (f2cl-lib:int-sub 1))) + ((> ki 1) nil) + (tagbody + (if (= ip 1) (go label130)) + (if (= ki 1) (go label40)) + (if + (= + (f2cl-lib:fref t$-%data% + (ki (f2cl-lib:int-sub ki 1)) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (go label40)) + (setf ip -1) + label40 + (cond + (somev + (cond + ((= ip 0) + (if + (not + (f2cl-lib:fref select-%data% + (ki) + ((1 *)) + select-%offset%)) + (go label130))) + (t + (if + (not + (f2cl-lib:fref select-%data% + ((f2cl-lib:int-sub ki 1)) + ((1 *)) + select-%offset%)) + (go label130)))))) + (setf wr + (f2cl-lib:fref t$-%data% + (ki ki) + ((1 ldt) (1 *)) + t$-%offset%)) + (setf wi zero) + (if (/= ip 0) + (setf wi + (* + (f2cl-lib:fsqrt + (abs + (f2cl-lib:fref t$-%data% + (ki (f2cl-lib:int-sub ki 1)) + ((1 ldt) (1 *)) + t$-%offset%))) + (f2cl-lib:fsqrt + (abs + (f2cl-lib:fref t$-%data% + ((f2cl-lib:int-sub ki 1) ki) + ((1 ldt) (1 *)) + t$-%offset%)))))) + (setf smin (max (* ulp (+ (abs wr) (abs wi))) smlnum)) + (cond + ((= ip 0) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki n)) + ((1 *)) + work-%offset%) + one) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add ki (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add k n)) + ((1 *)) + work-%offset%) + (- + (f2cl-lib:fref t$-%data% + (k ki) + ((1 ldt) (1 *)) + t$-%offset%))))) + (setf jnxt (f2cl-lib:int-sub ki 1)) + (f2cl-lib:fdo (j (f2cl-lib:int-add ki (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (if (> j jnxt) (go label60)) + (setf j1 j) + (setf j2 j) + (setf jnxt (f2cl-lib:int-sub j 1)) + (cond + ((> j 1) + (cond + ((/= + (f2cl-lib:fref t$ + (j + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + ((1 ldt) (1 *))) + zero) + (setf j1 (f2cl-lib:int-sub j 1)) + (setf jnxt (f2cl-lib:int-sub j 2)))))) + (cond + ((= j1 j2) + (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) + (dlaln2 nil 1 1 smin one + (f2cl-lib:array-slice t$ + double-float + (j j) + ((1 ldt) (1 *))) + ldt one one + (f2cl-lib:array-slice work + double-float + ((+ j n)) + ((1 *))) + n wr zero x 2 scale 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-11 var-12 var-13 var-14)) + (setf scale var-15) + (setf xnorm var-16) + (setf ierr var-17)) + (cond + ((> xnorm one) + (cond + ((> (f2cl-lib:fref work (j) ((1 *))) + (f2cl-lib:f2cl/ bignum xnorm)) + (setf (f2cl-lib:fref x (1 1) ((1 2) (1 2))) + (/ (f2cl-lib:fref x (1 1) ((1 2) (1 2))) + xnorm)) + (setf scale (/ scale xnorm)))))) + (if (/= scale one) + (dscal ki scale + (f2cl-lib:array-slice work + double-float + ((+ 1 n)) + ((1 *))) + 1)) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref x (1 1) ((1 2) (1 2)))) + (daxpy (f2cl-lib:int-sub j 1) + (- (f2cl-lib:fref x (1 1) ((1 2) (1 2)))) + (f2cl-lib:array-slice t$ + double-float + (1 j) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + ((+ 1 n)) + ((1 *))) + 1)) + (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) + (dlaln2 nil 2 1 smin one + (f2cl-lib:array-slice t$ + double-float + ((+ j (f2cl-lib:int-sub 1)) + (f2cl-lib:int-sub j 1)) + ((1 ldt) (1 *))) + ldt one one + (f2cl-lib:array-slice work + double-float + ((+ j + (f2cl-lib:int-sub 1) + n)) + ((1 *))) + n wr zero x 2 scale 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-11 var-12 var-13 var-14)) + (setf scale var-15) + (setf xnorm var-16) + (setf ierr var-17)) + (cond + ((> xnorm one) + (setf beta + (max + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-sub j 1)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref work-%data% + (j) + ((1 *)) + work-%offset%))) + (cond + ((> beta (f2cl-lib:f2cl/ bignum xnorm)) + (setf (f2cl-lib:fref x (1 1) ((1 2) (1 2))) + (/ (f2cl-lib:fref x (1 1) ((1 2) (1 2))) + xnorm)) + (setf (f2cl-lib:fref x (2 1) ((1 2) (1 2))) + (/ (f2cl-lib:fref x (2 1) ((1 2) (1 2))) + xnorm)) + (setf scale (/ scale xnorm)))))) + (if (/= scale one) + (dscal ki scale + (f2cl-lib:array-slice work + double-float + ((+ 1 n)) + ((1 *))) + 1)) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub j 1) + n)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref x (1 1) ((1 2) (1 2)))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref x (2 1) ((1 2) (1 2)))) + (daxpy (f2cl-lib:int-sub j 2) + (- (f2cl-lib:fref x (1 1) ((1 2) (1 2)))) + (f2cl-lib:array-slice t$ + double-float + (1 (f2cl-lib:int-sub j 1)) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + ((+ 1 n)) + ((1 *))) + 1) + (daxpy (f2cl-lib:int-sub j 2) + (- (f2cl-lib:fref x (2 1) ((1 2) (1 2)))) + (f2cl-lib:array-slice t$ + double-float + (1 j) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + ((+ 1 n)) + ((1 *))) + 1))) + label60)) + (cond + ((not over) + (dcopy ki + (f2cl-lib:array-slice work + double-float + ((+ 1 n)) + ((1 *))) + 1 + (f2cl-lib:array-slice vr + double-float + (1 is) + ((1 ldvr) (1 *))) + 1) + (setf ii + (idamax ki + (f2cl-lib:array-slice vr + double-float + (1 is) + ((1 ldvr) (1 *))) + 1)) + (setf remax + (/ one + (abs + (f2cl-lib:fref vr-%data% + (ii is) + ((1 ldvr) (1 *)) + vr-%offset%)))) + (dscal ki remax + (f2cl-lib:array-slice vr + double-float + (1 is) + ((1 ldvr) (1 *))) + 1) + (f2cl-lib:fdo (k (f2cl-lib:int-add ki 1) + (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (setf (f2cl-lib:fref vr-%data% + (k is) + ((1 ldvr) (1 *)) + vr-%offset%) + zero)))) + (t + (if (> ki 1) + (dgemv "N" n (f2cl-lib:int-sub ki 1) one vr ldvr + (f2cl-lib:array-slice work + double-float + ((+ 1 n)) + ((1 *))) + 1 + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki n)) + ((1 *)) + work-%offset%) + (f2cl-lib:array-slice vr + double-float + (1 ki) + ((1 ldvr) (1 *))) + 1)) + (setf ii + (idamax n + (f2cl-lib:array-slice vr + double-float + (1 ki) + ((1 ldvr) (1 *))) + 1)) + (setf remax + (/ one + (abs + (f2cl-lib:fref vr-%data% + (ii ki) + ((1 ldvr) (1 *)) + vr-%offset%)))) + (dscal n remax + (f2cl-lib:array-slice vr + double-float + (1 ki) + ((1 ldvr) (1 *))) + 1)))) + (t + (cond + ((>= + (abs + (f2cl-lib:fref t$ + ((f2cl-lib:int-add ki + (f2cl-lib:int-sub 1)) + ki) + ((1 ldt) (1 *)))) + (abs + (f2cl-lib:fref t$ + (ki + (f2cl-lib:int-add ki + (f2cl-lib:int-sub 1))) + ((1 ldt) (1 *))))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub ki 1) + n)) + ((1 *)) + work-%offset%) + one) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki n2)) + ((1 *)) + work-%offset%) + (/ wi + (f2cl-lib:fref t$-%data% + ((f2cl-lib:int-sub ki 1) ki) + ((1 ldt) (1 *)) + t$-%offset%)))) + (t + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub ki 1) + n)) + ((1 *)) + work-%offset%) + (/ (- wi) + (f2cl-lib:fref t$-%data% + (ki (f2cl-lib:int-sub ki 1)) + ((1 ldt) (1 *)) + t$-%offset%))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki n2)) + ((1 *)) + work-%offset%) + one))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki n)) + ((1 *)) + work-%offset%) + zero) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub ki 1) + n2)) + ((1 *)) + work-%offset%) + zero) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add ki (f2cl-lib:int-sub 2))) + nil) + (tagbody + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add k n)) + ((1 *)) + work-%offset%) + (* + (- + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub ki 1) + n)) + ((1 *)) + work-%offset%)) + (f2cl-lib:fref t$-%data% + (k (f2cl-lib:int-sub ki 1)) + ((1 ldt) (1 *)) + t$-%offset%))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add k n2)) + ((1 *)) + work-%offset%) + (* + (- + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki n2)) + ((1 *)) + work-%offset%)) + (f2cl-lib:fref t$-%data% + (k ki) + ((1 ldt) (1 *)) + t$-%offset%))))) + (setf jnxt (f2cl-lib:int-sub ki 2)) + (f2cl-lib:fdo (j (f2cl-lib:int-add ki (f2cl-lib:int-sub 2)) + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (if (> j jnxt) (go label90)) + (setf j1 j) + (setf j2 j) + (setf jnxt (f2cl-lib:int-sub j 1)) + (cond + ((> j 1) + (cond + ((/= + (f2cl-lib:fref t$ + (j + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + ((1 ldt) (1 *))) + zero) + (setf j1 (f2cl-lib:int-sub j 1)) + (setf jnxt (f2cl-lib:int-sub j 2)))))) + (cond + ((= j1 j2) + (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) + (dlaln2 nil 1 2 smin one + (f2cl-lib:array-slice t$ + double-float + (j j) + ((1 ldt) (1 *))) + ldt one one + (f2cl-lib:array-slice work + double-float + ((+ j n)) + ((1 *))) + n wr wi x 2 scale 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-11 var-12 var-13 var-14)) + (setf scale var-15) + (setf xnorm var-16) + (setf ierr var-17)) + (cond + ((> xnorm one) + (cond + ((> (f2cl-lib:fref work (j) ((1 *))) + (f2cl-lib:f2cl/ bignum xnorm)) + (setf (f2cl-lib:fref x (1 1) ((1 2) (1 2))) + (/ (f2cl-lib:fref x (1 1) ((1 2) (1 2))) + xnorm)) + (setf (f2cl-lib:fref x (1 2) ((1 2) (1 2))) + (/ (f2cl-lib:fref x (1 2) ((1 2) (1 2))) + xnorm)) + (setf scale (/ scale xnorm)))))) + (cond + ((/= scale one) + (dscal ki scale + (f2cl-lib:array-slice work + double-float + ((+ 1 n)) + ((1 *))) + 1) + (dscal ki scale + (f2cl-lib:array-slice work + double-float + ((+ 1 n2)) + ((1 *))) + 1))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref x (1 1) ((1 2) (1 2)))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n2)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref x (1 2) ((1 2) (1 2)))) + (daxpy (f2cl-lib:int-sub j 1) + (- (f2cl-lib:fref x (1 1) ((1 2) (1 2)))) + (f2cl-lib:array-slice t$ + double-float + (1 j) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + ((+ 1 n)) + ((1 *))) + 1) + (daxpy (f2cl-lib:int-sub j 1) + (- (f2cl-lib:fref x (1 2) ((1 2) (1 2)))) + (f2cl-lib:array-slice t$ + double-float + (1 j) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + ((+ 1 n2)) + ((1 *))) + 1)) + (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) + (dlaln2 nil 2 2 smin one + (f2cl-lib:array-slice t$ + double-float + ((+ j (f2cl-lib:int-sub 1)) + (f2cl-lib:int-sub j 1)) + ((1 ldt) (1 *))) + ldt one one + (f2cl-lib:array-slice work + double-float + ((+ j + (f2cl-lib:int-sub 1) + n)) + ((1 *))) + n wr wi x 2 scale 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-11 var-12 var-13 var-14)) + (setf scale var-15) + (setf xnorm var-16) + (setf ierr var-17)) + (cond + ((> xnorm one) + (setf beta + (max + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-sub j 1)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref work-%data% + (j) + ((1 *)) + work-%offset%))) + (cond + ((> beta (f2cl-lib:f2cl/ bignum xnorm)) + (setf rec (/ one xnorm)) + (setf (f2cl-lib:fref x (1 1) ((1 2) (1 2))) + (* (f2cl-lib:fref x (1 1) ((1 2) (1 2))) + rec)) + (setf (f2cl-lib:fref x (1 2) ((1 2) (1 2))) + (* (f2cl-lib:fref x (1 2) ((1 2) (1 2))) + rec)) + (setf (f2cl-lib:fref x (2 1) ((1 2) (1 2))) + (* (f2cl-lib:fref x (2 1) ((1 2) (1 2))) + rec)) + (setf (f2cl-lib:fref x (2 2) ((1 2) (1 2))) + (* (f2cl-lib:fref x (2 2) ((1 2) (1 2))) + rec)) + (setf scale (* scale rec)))))) + (cond + ((/= scale one) + (dscal ki scale + (f2cl-lib:array-slice work + double-float + ((+ 1 n)) + ((1 *))) + 1) + (dscal ki scale + (f2cl-lib:array-slice work + double-float + ((+ 1 n2)) + ((1 *))) + 1))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub j 1) + n)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref x (1 1) ((1 2) (1 2)))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref x (2 1) ((1 2) (1 2)))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub j 1) + n2)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref x (1 2) ((1 2) (1 2)))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n2)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref x (2 2) ((1 2) (1 2)))) + (daxpy (f2cl-lib:int-sub j 2) + (- (f2cl-lib:fref x (1 1) ((1 2) (1 2)))) + (f2cl-lib:array-slice t$ + double-float + (1 (f2cl-lib:int-sub j 1)) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + ((+ 1 n)) + ((1 *))) + 1) + (daxpy (f2cl-lib:int-sub j 2) + (- (f2cl-lib:fref x (2 1) ((1 2) (1 2)))) + (f2cl-lib:array-slice t$ + double-float + (1 j) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + ((+ 1 n)) + ((1 *))) + 1) + (daxpy (f2cl-lib:int-sub j 2) + (- (f2cl-lib:fref x (1 2) ((1 2) (1 2)))) + (f2cl-lib:array-slice t$ + double-float + (1 (f2cl-lib:int-sub j 1)) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + ((+ 1 n2)) + ((1 *))) + 1) + (daxpy (f2cl-lib:int-sub j 2) + (- (f2cl-lib:fref x (2 2) ((1 2) (1 2)))) + (f2cl-lib:array-slice t$ + double-float + (1 j) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + ((+ 1 n2)) + ((1 *))) + 1))) + label90)) + (cond + ((not over) + (dcopy ki + (f2cl-lib:array-slice work + double-float + ((+ 1 n)) + ((1 *))) + 1 + (f2cl-lib:array-slice vr + double-float + (1 (f2cl-lib:int-sub is 1)) + ((1 ldvr) (1 *))) + 1) + (dcopy ki + (f2cl-lib:array-slice work + double-float + ((+ 1 n2)) + ((1 *))) + 1 + (f2cl-lib:array-slice vr + double-float + (1 is) + ((1 ldvr) (1 *))) + 1) + (setf emax zero) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k ki) nil) + (tagbody + (setf emax + (max emax + (+ + (abs + (f2cl-lib:fref vr-%data% + (k + (f2cl-lib:int-sub is + 1)) + ((1 ldvr) (1 *)) + vr-%offset%)) + (abs + (f2cl-lib:fref vr-%data% + (k is) + ((1 ldvr) (1 *)) + vr-%offset%))))))) + (setf remax (/ one emax)) + (dscal ki remax + (f2cl-lib:array-slice vr + double-float + (1 (f2cl-lib:int-sub is 1)) + ((1 ldvr) (1 *))) + 1) + (dscal ki remax + (f2cl-lib:array-slice vr + double-float + (1 is) + ((1 ldvr) (1 *))) + 1) + (f2cl-lib:fdo (k (f2cl-lib:int-add ki 1) + (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (setf (f2cl-lib:fref vr-%data% + (k (f2cl-lib:int-sub is 1)) + ((1 ldvr) (1 *)) + vr-%offset%) + zero) + (setf (f2cl-lib:fref vr-%data% + (k is) + ((1 ldvr) (1 *)) + vr-%offset%) + zero)))) + (t + (cond + ((> ki 2) + (dgemv "N" n (f2cl-lib:int-sub ki 2) one vr ldvr + (f2cl-lib:array-slice work + double-float + ((+ 1 n)) + ((1 *))) + 1 + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub ki 1) + n)) + ((1 *)) + work-%offset%) + (f2cl-lib:array-slice vr + double-float + (1 (f2cl-lib:int-sub ki 1)) + ((1 ldvr) (1 *))) + 1) + (dgemv "N" n (f2cl-lib:int-sub ki 2) one vr ldvr + (f2cl-lib:array-slice work + double-float + ((+ 1 n2)) + ((1 *))) + 1 + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki n2)) + ((1 *)) + work-%offset%) + (f2cl-lib:array-slice vr + double-float + (1 ki) + ((1 ldvr) (1 *))) + 1)) + (t + (dscal n + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub ki 1) + n)) + ((1 *)) + work-%offset%) + (f2cl-lib:array-slice vr + double-float + (1 (f2cl-lib:int-sub ki 1)) + ((1 ldvr) (1 *))) + 1) + (dscal n + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki n2)) + ((1 *)) + work-%offset%) + (f2cl-lib:array-slice vr + double-float + (1 ki) + ((1 ldvr) (1 *))) + 1))) + (setf emax zero) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (setf emax + (max emax + (+ + (abs + (f2cl-lib:fref vr-%data% + (k + (f2cl-lib:int-sub ki + 1)) + ((1 ldvr) (1 *)) + vr-%offset%)) + (abs + (f2cl-lib:fref vr-%data% + (k ki) + ((1 ldvr) (1 *)) + vr-%offset%))))))) + (setf remax (/ one emax)) + (dscal n remax + (f2cl-lib:array-slice vr + double-float + (1 (f2cl-lib:int-sub ki 1)) + ((1 ldvr) (1 *))) + 1) + (dscal n remax + (f2cl-lib:array-slice vr + double-float + (1 ki) + ((1 ldvr) (1 *))) + 1))))) + (setf is (f2cl-lib:int-sub is 1)) + (if (/= ip 0) (setf is (f2cl-lib:int-sub is 1))) + label130 + (if (= ip 1) (setf ip 0)) + (if (= ip -1) (setf ip 1)))))) + (cond + (leftv + (setf ip 0) + (setf is 1) + (f2cl-lib:fdo (ki 1 (f2cl-lib:int-add ki 1)) + ((> ki n) nil) + (tagbody + (if (= ip -1) (go label250)) + (if (= ki n) (go label150)) + (if + (= + (f2cl-lib:fref t$-%data% + ((f2cl-lib:int-add ki 1) ki) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (go label150)) + (setf ip 1) + label150 + (cond + (somev + (if + (not + (f2cl-lib:fref select-%data% (ki) ((1 *)) select-%offset%)) + (go label250)))) + (setf wr + (f2cl-lib:fref t$-%data% + (ki ki) + ((1 ldt) (1 *)) + t$-%offset%)) + (setf wi zero) + (if (/= ip 0) + (setf wi + (* + (f2cl-lib:fsqrt + (abs + (f2cl-lib:fref t$-%data% + (ki (f2cl-lib:int-add ki 1)) + ((1 ldt) (1 *)) + t$-%offset%))) + (f2cl-lib:fsqrt + (abs + (f2cl-lib:fref t$-%data% + ((f2cl-lib:int-add ki 1) ki) + ((1 ldt) (1 *)) + t$-%offset%)))))) + (setf smin (max (* ulp (+ (abs wr) (abs wi))) smlnum)) + (cond + ((= ip 0) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki n)) + ((1 *)) + work-%offset%) + one) + (f2cl-lib:fdo (k (f2cl-lib:int-add ki 1) + (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add k n)) + ((1 *)) + work-%offset%) + (- + (f2cl-lib:fref t$-%data% + (ki k) + ((1 ldt) (1 *)) + t$-%offset%))))) + (setf vmax one) + (setf vcrit bignum) + (setf jnxt (f2cl-lib:int-add ki 1)) + (f2cl-lib:fdo (j (f2cl-lib:int-add ki 1) + (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (if (< j jnxt) (go label170)) + (setf j1 j) + (setf j2 j) + (setf jnxt (f2cl-lib:int-add j 1)) + (cond + ((< j n) + (cond + ((/= + (f2cl-lib:fref t$ + ((f2cl-lib:int-add j 1) j) + ((1 ldt) (1 *))) + zero) + (setf j2 (f2cl-lib:int-add j 1)) + (setf jnxt (f2cl-lib:int-add j 2)))))) + (cond + ((= j1 j2) + (cond + ((> (f2cl-lib:fref work (j) ((1 *))) vcrit) + (setf rec (/ one vmax)) + (dscal (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1) + rec + (f2cl-lib:array-slice work + double-float + ((+ ki n)) + ((1 *))) + 1) + (setf vmax one) + (setf vcrit bignum))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n)) + ((1 *)) + work-%offset%) + (- + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n)) + ((1 *)) + work-%offset%) + (ddot (f2cl-lib:int-sub j ki 1) + (f2cl-lib:array-slice t$ + double-float + ((+ ki 1) j) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + ((+ ki 1 n)) + ((1 *))) + 1))) + (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) + (dlaln2 nil 1 1 smin one + (f2cl-lib:array-slice t$ + double-float + (j j) + ((1 ldt) (1 *))) + ldt one one + (f2cl-lib:array-slice work + double-float + ((+ j n)) + ((1 *))) + n wr zero x 2 scale 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-11 var-12 var-13 var-14)) + (setf scale var-15) + (setf xnorm var-16) + (setf ierr var-17)) + (if (/= scale one) + (dscal + (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1) + scale + (f2cl-lib:array-slice work + double-float + ((+ ki n)) + ((1 *))) + 1)) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref x (1 1) ((1 2) (1 2)))) + (setf vmax + (max + (abs + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n)) + ((1 *)) + work-%offset%)) + vmax)) + (setf vcrit (/ bignum vmax))) + (t + (setf beta + (max + (f2cl-lib:fref work-%data% + (j) + ((1 *)) + work-%offset%) + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j 1)) + ((1 *)) + work-%offset%))) + (cond + ((> beta vcrit) + (setf rec (/ one vmax)) + (dscal (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1) + rec + (f2cl-lib:array-slice work + double-float + ((+ ki n)) + ((1 *))) + 1) + (setf vmax one) + (setf vcrit bignum))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n)) + ((1 *)) + work-%offset%) + (- + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n)) + ((1 *)) + work-%offset%) + (ddot (f2cl-lib:int-sub j ki 1) + (f2cl-lib:array-slice t$ + double-float + ((+ ki 1) j) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + ((+ ki 1 n)) + ((1 *))) + 1))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j 1 n)) + ((1 *)) + work-%offset%) + (- + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j 1 n)) + ((1 *)) + work-%offset%) + (ddot (f2cl-lib:int-sub j ki 1) + (f2cl-lib:array-slice t$ + double-float + ((+ ki 1) + (f2cl-lib:int-add j + 1)) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + ((+ ki 1 n)) + ((1 *))) + 1))) + (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) + (dlaln2 t 2 1 smin one + (f2cl-lib:array-slice t$ + double-float + (j j) + ((1 ldt) (1 *))) + ldt one one + (f2cl-lib:array-slice work + double-float + ((+ j n)) + ((1 *))) + n wr zero x 2 scale 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-11 var-12 var-13 var-14)) + (setf scale var-15) + (setf xnorm var-16) + (setf ierr var-17)) + (if (/= scale one) + (dscal + (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1) + scale + (f2cl-lib:array-slice work + double-float + ((+ ki n)) + ((1 *))) + 1)) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref x (1 1) ((1 2) (1 2)))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j 1 n)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref x (2 1) ((1 2) (1 2)))) + (setf vmax + (max + (abs + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n)) + ((1 *)) + work-%offset%)) + (abs + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j 1 n)) + ((1 *)) + work-%offset%)) + vmax)) + (setf vcrit (/ bignum vmax)))) + label170)) + (cond + ((not over) + (dcopy (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1) + (f2cl-lib:array-slice work + double-float + ((+ ki n)) + ((1 *))) + 1 + (f2cl-lib:array-slice vl + double-float + (ki is) + ((1 ldvl) (1 *))) + 1) + (setf ii + (f2cl-lib:int-sub + (f2cl-lib:int-add + (idamax + (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1) + (f2cl-lib:array-slice vl + double-float + (ki is) + ((1 ldvl) (1 *))) + 1) + ki) + 1)) + (setf remax + (/ one + (abs + (f2cl-lib:fref vl-%data% + (ii is) + ((1 ldvl) (1 *)) + vl-%offset%)))) + (dscal (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1) remax + (f2cl-lib:array-slice vl + double-float + (ki is) + ((1 ldvl) (1 *))) + 1) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add ki + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref vl-%data% + (k is) + ((1 ldvl) (1 *)) + vl-%offset%) + zero)))) + (t + (if (< ki n) + (dgemv "N" n (f2cl-lib:int-sub n ki) one + (f2cl-lib:array-slice vl + double-float + (1 (f2cl-lib:int-add ki 1)) + ((1 ldvl) (1 *))) + ldvl + (f2cl-lib:array-slice work + double-float + ((+ ki 1 n)) + ((1 *))) + 1 + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki n)) + ((1 *)) + work-%offset%) + (f2cl-lib:array-slice vl + double-float + (1 ki) + ((1 ldvl) (1 *))) + 1)) + (setf ii + (idamax n + (f2cl-lib:array-slice vl + double-float + (1 ki) + ((1 ldvl) (1 *))) + 1)) + (setf remax + (/ one + (abs + (f2cl-lib:fref vl-%data% + (ii ki) + ((1 ldvl) (1 *)) + vl-%offset%)))) + (dscal n remax + (f2cl-lib:array-slice vl + double-float + (1 ki) + ((1 ldvl) (1 *))) + 1)))) + (t + (tagbody + (cond + ((>= + (abs + (f2cl-lib:fref t$ + (ki (f2cl-lib:int-add ki 1)) + ((1 ldt) (1 *)))) + (abs + (f2cl-lib:fref t$ + ((f2cl-lib:int-add ki 1) ki) + ((1 ldt) (1 *))))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki n)) + ((1 *)) + work-%offset%) + (/ wi + (f2cl-lib:fref t$-%data% + (ki (f2cl-lib:int-add ki 1)) + ((1 ldt) (1 *)) + t$-%offset%))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki 1 n2)) + ((1 *)) + work-%offset%) + one)) + (t + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki n)) + ((1 *)) + work-%offset%) + one) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki 1 n2)) + ((1 *)) + work-%offset%) + (/ (- wi) + (f2cl-lib:fref t$-%data% + ((f2cl-lib:int-add ki 1) ki) + ((1 ldt) (1 *)) + t$-%offset%))))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki 1 n)) + ((1 *)) + work-%offset%) + zero) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki n2)) + ((1 *)) + work-%offset%) + zero) + (f2cl-lib:fdo (k (f2cl-lib:int-add ki 2) + (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add k n)) + ((1 *)) + work-%offset%) + (* + (- + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki n)) + ((1 *)) + work-%offset%)) + (f2cl-lib:fref t$-%data% + (ki k) + ((1 ldt) (1 *)) + t$-%offset%))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add k n2)) + ((1 *)) + work-%offset%) + (* + (- + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki 1 n2)) + ((1 *)) + work-%offset%)) + (f2cl-lib:fref t$-%data% + ((f2cl-lib:int-add ki 1) k) + ((1 ldt) (1 *)) + t$-%offset%))))) + (setf vmax one) + (setf vcrit bignum) + (setf jnxt (f2cl-lib:int-add ki 2)) + (f2cl-lib:fdo (j (f2cl-lib:int-add ki 2) + (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (if (< j jnxt) (go label200)) + (setf j1 j) + (setf j2 j) + (setf jnxt (f2cl-lib:int-add j 1)) + (cond + ((< j n) + (cond + ((/= + (f2cl-lib:fref t$ + ((f2cl-lib:int-add j 1) j) + ((1 ldt) (1 *))) + zero) + (setf j2 (f2cl-lib:int-add j 1)) + (setf jnxt (f2cl-lib:int-add j 2)))))) + (cond + ((= j1 j2) + (cond + ((> (f2cl-lib:fref work (j) ((1 *))) vcrit) + (setf rec (/ one vmax)) + (dscal + (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1) rec + (f2cl-lib:array-slice work + double-float + ((+ ki n)) + ((1 *))) + 1) + (dscal + (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1) rec + (f2cl-lib:array-slice work + double-float + ((+ ki n2)) + ((1 *))) + 1) + (setf vmax one) + (setf vcrit bignum))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n)) + ((1 *)) + work-%offset%) + (- + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n)) + ((1 *)) + work-%offset%) + (ddot (f2cl-lib:int-sub j ki 2) + (f2cl-lib:array-slice t$ + double-float + ((+ ki 2) j) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + ((+ ki 2 n)) + ((1 *))) + 1))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n2)) + ((1 *)) + work-%offset%) + (- + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n2)) + ((1 *)) + work-%offset%) + (ddot (f2cl-lib:int-sub j ki 2) + (f2cl-lib:array-slice t$ + double-float + ((+ ki 2) j) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + ((+ ki 2 n2)) + ((1 *))) + 1))) + (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) + (dlaln2 nil 1 2 smin one + (f2cl-lib:array-slice t$ + double-float + (j j) + ((1 ldt) (1 *))) + ldt one one + (f2cl-lib:array-slice work + double-float + ((+ j n)) + ((1 *))) + n wr (- wi) x 2 scale 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-11 var-12 var-13 + var-14)) + (setf scale var-15) + (setf xnorm var-16) + (setf ierr var-17)) + (cond + ((/= scale one) + (dscal + (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1) + scale + (f2cl-lib:array-slice work + double-float + ((+ ki n)) + ((1 *))) + 1) + (dscal + (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1) + scale + (f2cl-lib:array-slice work + double-float + ((+ ki n2)) + ((1 *))) + 1))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref x (1 1) ((1 2) (1 2)))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n2)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref x (1 2) ((1 2) (1 2)))) + (setf vmax + (max + (abs + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n)) + ((1 *)) + work-%offset%)) + (abs + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n2)) + ((1 *)) + work-%offset%)) + vmax)) + (setf vcrit (/ bignum vmax))) + (t + (setf beta + (max + (f2cl-lib:fref work-%data% + (j) + ((1 *)) + work-%offset%) + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j 1)) + ((1 *)) + work-%offset%))) + (cond + ((> beta vcrit) + (setf rec (/ one vmax)) + (dscal + (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1) rec + (f2cl-lib:array-slice work + double-float + ((+ ki n)) + ((1 *))) + 1) + (dscal + (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1) rec + (f2cl-lib:array-slice work + double-float + ((+ ki n2)) + ((1 *))) + 1) + (setf vmax one) + (setf vcrit bignum))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n)) + ((1 *)) + work-%offset%) + (- + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n)) + ((1 *)) + work-%offset%) + (ddot (f2cl-lib:int-sub j ki 2) + (f2cl-lib:array-slice t$ + double-float + ((+ ki 2) j) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + ((+ ki 2 n)) + ((1 *))) + 1))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n2)) + ((1 *)) + work-%offset%) + (- + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n2)) + ((1 *)) + work-%offset%) + (ddot (f2cl-lib:int-sub j ki 2) + (f2cl-lib:array-slice t$ + double-float + ((+ ki 2) j) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + ((+ ki 2 n2)) + ((1 *))) + 1))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j 1 n)) + ((1 *)) + work-%offset%) + (- + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j 1 n)) + ((1 *)) + work-%offset%) + (ddot (f2cl-lib:int-sub j ki 2) + (f2cl-lib:array-slice t$ + double-float + ((+ ki 2) + (f2cl-lib:int-add j + 1)) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + ((+ ki 2 n)) + ((1 *))) + 1))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j 1 n2)) + ((1 *)) + work-%offset%) + (- + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j 1 n2)) + ((1 *)) + work-%offset%) + (ddot (f2cl-lib:int-sub j ki 2) + (f2cl-lib:array-slice t$ + double-float + ((+ ki 2) + (f2cl-lib:int-add j + 1)) + ((1 ldt) (1 *))) + 1 + (f2cl-lib:array-slice work + double-float + ((+ ki 2 n2)) + ((1 *))) + 1))) + (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) + (dlaln2 t 2 2 smin one + (f2cl-lib:array-slice t$ + double-float + (j j) + ((1 ldt) (1 *))) + ldt one one + (f2cl-lib:array-slice work + double-float + ((+ j n)) + ((1 *))) + n wr (- wi) x 2 scale 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-11 var-12 var-13 + var-14)) + (setf scale var-15) + (setf xnorm var-16) + (setf ierr var-17)) + (cond + ((/= scale one) + (dscal + (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1) + scale + (f2cl-lib:array-slice work + double-float + ((+ ki n)) + ((1 *))) + 1) + (dscal + (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1) + scale + (f2cl-lib:array-slice work + double-float + ((+ ki n2)) + ((1 *))) + 1))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref x (1 1) ((1 2) (1 2)))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j n2)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref x (1 2) ((1 2) (1 2)))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j 1 n)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref x (2 1) ((1 2) (1 2)))) + (setf (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add j 1 n2)) + ((1 *)) + work-%offset%) + (f2cl-lib:fref x (2 2) ((1 2) (1 2)))) + (setf vmax + (max + (abs (f2cl-lib:fref x (1 1) ((1 2) (1 2)))) + (abs (f2cl-lib:fref x (1 2) ((1 2) (1 2)))) + (abs (f2cl-lib:fref x (2 1) ((1 2) (1 2)))) + (abs (f2cl-lib:fref x (2 2) ((1 2) (1 2)))) + vmax)) + (setf vcrit (/ bignum vmax)))) + label200)) + label210 + (cond + ((not over) + (dcopy (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1) + (f2cl-lib:array-slice work + double-float + ((+ ki n)) + ((1 *))) + 1 + (f2cl-lib:array-slice vl + double-float + (ki is) + ((1 ldvl) (1 *))) + 1) + (dcopy (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1) + (f2cl-lib:array-slice work + double-float + ((+ ki n2)) + ((1 *))) + 1 + (f2cl-lib:array-slice vl + double-float + (ki (f2cl-lib:int-add is 1)) + ((1 ldvl) (1 *))) + 1) + (setf emax zero) + (f2cl-lib:fdo (k ki (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (setf emax + (max emax + (+ + (abs + (f2cl-lib:fref vl-%data% + (k is) + ((1 ldvl) (1 *)) + vl-%offset%)) + (abs + (f2cl-lib:fref vl-%data% + (k + (f2cl-lib:int-add is + 1)) + ((1 ldvl) (1 *)) + vl-%offset%))))))) + (setf remax (/ one emax)) + (dscal (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1) + remax + (f2cl-lib:array-slice vl + double-float + (ki is) + ((1 ldvl) (1 *))) + 1) + (dscal (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1) + remax + (f2cl-lib:array-slice vl + double-float + (ki (f2cl-lib:int-add is 1)) + ((1 ldvl) (1 *))) + 1) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add ki + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref vl-%data% + (k is) + ((1 ldvl) (1 *)) + vl-%offset%) + zero) + (setf (f2cl-lib:fref vl-%data% + (k (f2cl-lib:int-add is 1)) + ((1 ldvl) (1 *)) + vl-%offset%) + zero)))) + (t + (cond + ((< ki (f2cl-lib:int-add n (f2cl-lib:int-sub 1))) + (dgemv "N" n (f2cl-lib:int-sub n ki 1) one + (f2cl-lib:array-slice vl + double-float + (1 (f2cl-lib:int-add ki 2)) + ((1 ldvl) (1 *))) + ldvl + (f2cl-lib:array-slice work + double-float + ((+ ki 2 n)) + ((1 *))) + 1 + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki n)) + ((1 *)) + work-%offset%) + (f2cl-lib:array-slice vl + double-float + (1 ki) + ((1 ldvl) (1 *))) + 1) + (dgemv "N" n (f2cl-lib:int-sub n ki 1) one + (f2cl-lib:array-slice vl + double-float + (1 (f2cl-lib:int-add ki 2)) + ((1 ldvl) (1 *))) + ldvl + (f2cl-lib:array-slice work + double-float + ((+ ki 2 n2)) + ((1 *))) + 1 + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki 1 n2)) + ((1 *)) + work-%offset%) + (f2cl-lib:array-slice vl + double-float + (1 (f2cl-lib:int-add ki 1)) + ((1 ldvl) (1 *))) + 1)) + (t + (dscal n + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki n)) + ((1 *)) + work-%offset%) + (f2cl-lib:array-slice vl + double-float + (1 ki) + ((1 ldvl) (1 *))) + 1) + (dscal n + (f2cl-lib:fref work-%data% + ((f2cl-lib:int-add ki 1 n2)) + ((1 *)) + work-%offset%) + (f2cl-lib:array-slice vl + double-float + (1 (f2cl-lib:int-add ki 1)) + ((1 ldvl) (1 *))) + 1))) + (setf emax zero) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (setf emax + (max emax + (+ + (abs + (f2cl-lib:fref vl-%data% + (k ki) + ((1 ldvl) (1 *)) + vl-%offset%)) + (abs + (f2cl-lib:fref vl-%data% + (k + (f2cl-lib:int-add ki + 1)) + ((1 ldvl) (1 *)) + vl-%offset%))))))) + (setf remax (/ one emax)) + (dscal n remax + (f2cl-lib:array-slice vl + double-float + (1 ki) + ((1 ldvl) (1 *))) + 1) + (dscal n remax + (f2cl-lib:array-slice vl + double-float + (1 (f2cl-lib:int-add ki 1)) + ((1 ldvl) (1 *))) + 1)))))) + (setf is (f2cl-lib:int-add is 1)) + (if (/= ip 0) (setf is (f2cl-lib:int-add is 1))) + label250 + (if (= ip -1) (setf ip 0)) + (if (= ip 1) (setf ip -1)))))) + end_label + (return + (values nil nil nil nil nil nil nil nil nil nil nil m 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::dtrevc + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + (simple-array character (1)) + (array (member t nil) (*)) + fixnum (array double-float (*)) + fixnum (array double-float (*)) + fixnum (array double-float (*)) + fixnum fixnum + fixnum (array double-float (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil + fortran-to-lisp::m nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::ddot fortran-to-lisp::dgemv + fortran-to-lisp::idamax fortran-to-lisp::dcopy + fortran-to-lisp::daxpy fortran-to-lisp::dscal + fortran-to-lisp::dlaln2 fortran-to-lisp::dlabad + fortran-to-lisp::dlamch fortran-to-lisp::xerbla + fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dtrexc LAPACK} +\pagehead{dtrexc}{dtrexc} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dtrexc (compq n t$ ldt q ldq ifst ilst work info) + (declare (type (array double-float (*)) work q t$) + (type fixnum info ilst ifst ldq ldt n) + (type (simple-array character (*)) compq)) + (f2cl-lib:with-multi-array-data + ((compq character compq-%data% compq-%offset%) + (t$ double-float t$-%data% t$-%offset%) + (q double-float q-%data% q-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((here 0) (nbf 0) (nbl 0) (nbnext 0) (wantq nil)) + (declare (type fixnum here nbf nbl nbnext) + (type (member t nil) wantq)) + (setf info 0) + (setf wantq (lsame compq "V")) + (cond + ((and (not wantq) (not (lsame compq "N"))) + (setf info -1)) + ((< n 0) + (setf info -2)) + ((< ldt (max (the fixnum 1) (the fixnum n))) + (setf info -4)) + ((or (< ldq 1) + (and wantq + (< ldq + (max (the fixnum 1) + (the fixnum n))))) + (setf info -6)) + ((or (< ifst 1) (> ifst n)) + (setf info -7)) + ((or (< ilst 1) (> ilst n)) + (setf info -8))) + (cond + ((/= info 0) + (xerbla "DTREXC" (f2cl-lib:int-sub info)) + (go end_label))) + (if (<= n 1) (go end_label)) + (cond + ((> ifst 1) + (if + (/= + (f2cl-lib:fref t$-%data% + (ifst (f2cl-lib:int-sub ifst 1)) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (setf ifst (f2cl-lib:int-sub ifst 1))))) + (setf nbf 1) + (cond + ((< ifst n) + (if + (/= + (f2cl-lib:fref t$-%data% + ((f2cl-lib:int-add ifst 1) ifst) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (setf nbf 2)))) + (cond + ((> ilst 1) + (if + (/= + (f2cl-lib:fref t$-%data% + (ilst (f2cl-lib:int-sub ilst 1)) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (setf ilst (f2cl-lib:int-sub ilst 1))))) + (setf nbl 1) + (cond + ((< ilst n) + (if + (/= + (f2cl-lib:fref t$-%data% + ((f2cl-lib:int-add ilst 1) ilst) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (setf nbl 2)))) + (if (= ifst ilst) (go end_label)) + (cond + ((< ifst ilst) + (tagbody + (if (and (= nbf 2) (= nbl 1)) + (setf ilst (f2cl-lib:int-sub ilst 1))) + (if (and (= nbf 1) (= nbl 2)) + (setf ilst (f2cl-lib:int-add ilst 1))) + (setf here ifst) + label10 + (cond + ((or (= nbf 1) (= nbf 2)) + (setf nbnext 1) + (cond + ((<= (f2cl-lib:int-add here nbf 1) n) + (if + (/= + (f2cl-lib:fref t$-%data% + ((f2cl-lib:int-add here nbf 1) + (f2cl-lib:int-add here nbf)) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (setf nbnext 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) + (dlaexc wantq n t$ ldt q ldq here nbf nbnext work info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf info var-10)) + (cond + ((/= info 0) + (setf ilst here) + (go end_label))) + (setf here (f2cl-lib:int-add here nbnext)) + (cond + ((= nbf 2) + (if + (= + (f2cl-lib:fref t$-%data% + ((f2cl-lib:int-add here 1) here) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (setf nbf 3))))) + (t + (setf nbnext 1) + (cond + ((<= (f2cl-lib:int-add here 3) n) + (if + (/= + (f2cl-lib:fref t$-%data% + ((f2cl-lib:int-add here 3) + (f2cl-lib:int-add here 2)) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (setf nbnext 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) + (dlaexc wantq n t$ ldt q ldq (f2cl-lib:int-add here 1) 1 + nbnext work info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf info var-10)) + (cond + ((/= info 0) + (setf ilst here) + (go end_label))) + (cond + ((= nbnext 1) + (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) + (dlaexc wantq n t$ ldt q ldq here 1 nbnext work info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf info var-10)) + (setf here (f2cl-lib:int-add here 1))) + (t + (if + (= + (f2cl-lib:fref t$-%data% + ((f2cl-lib:int-add here 2) + (f2cl-lib:int-add here 1)) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (setf nbnext 1)) + (cond + ((= nbnext 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) + (dlaexc wantq n t$ ldt q ldq here 1 nbnext work info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf info var-10)) + (cond + ((/= info 0) + (setf ilst here) + (go end_label))) + (setf here (f2cl-lib:int-add here 2))) + (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) + (dlaexc wantq n t$ ldt q ldq here 1 1 work info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf info 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) + (dlaexc wantq n t$ ldt q ldq + (f2cl-lib:int-add here 1) 1 1 work info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf info var-10)) + (setf here (f2cl-lib:int-add here 2)))))))) + (if (< here ilst) (go label10)))) + (t + (tagbody + (setf here ifst) + label20 + (cond + ((or (= nbf 1) (= nbf 2)) + (setf nbnext 1) + (cond + ((>= here 3) + (if + (/= + (f2cl-lib:fref t$-%data% + ((f2cl-lib:int-sub here 1) + (f2cl-lib:int-sub here 2)) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (setf nbnext 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) + (dlaexc wantq n t$ ldt q ldq (f2cl-lib:int-sub here nbnext) + nbnext nbf work info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf info var-10)) + (cond + ((/= info 0) + (setf ilst here) + (go end_label))) + (setf here (f2cl-lib:int-sub here nbnext)) + (cond + ((= nbf 2) + (if + (= + (f2cl-lib:fref t$-%data% + ((f2cl-lib:int-add here 1) here) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (setf nbf 3))))) + (t + (setf nbnext 1) + (cond + ((>= here 3) + (if + (/= + (f2cl-lib:fref t$-%data% + ((f2cl-lib:int-sub here 1) + (f2cl-lib:int-sub here 2)) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (setf nbnext 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) + (dlaexc wantq n t$ ldt q ldq (f2cl-lib:int-sub here nbnext) + nbnext 1 work info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf info var-10)) + (cond + ((/= info 0) + (setf ilst here) + (go end_label))) + (cond + ((= nbnext 1) + (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) + (dlaexc wantq n t$ ldt q ldq here nbnext 1 work info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 + var-7 var-8 var-9)) + (setf info var-10)) + (setf here (f2cl-lib:int-sub here 1))) + (t + (if + (= + (f2cl-lib:fref t$-%data% + (here (f2cl-lib:int-sub here 1)) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + (setf nbnext 1)) + (cond + ((= nbnext 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) + (dlaexc wantq n t$ ldt q ldq + (f2cl-lib:int-sub here 1) 2 1 work info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf info var-10)) + (cond + ((/= info 0) + (setf ilst here) + (go end_label))) + (setf here (f2cl-lib:int-sub here 2))) + (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) + (dlaexc wantq n t$ ldt q ldq here 1 1 work info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf info 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) + (dlaexc wantq n t$ ldt q ldq + (f2cl-lib:int-sub here 1) 1 1 work info) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 + var-6 var-7 var-8 var-9)) + (setf info var-10)) + (setf here (f2cl-lib:int-sub here 2)))))))) + (if (> here ilst) (go label20))))) + (setf ilst here) + end_label + (return (values nil nil nil nil nil nil ifst ilst 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::dtrexc + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum (array double-float (*)) + fixnum (array double-float (*)) + fixnum fixnum + fixnum (array double-float (*)) + fixnum) + :return-values '(nil nil nil nil nil nil fortran-to-lisp::ifst + fortran-to-lisp::ilst nil fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlaexc fortran-to-lisp::xerbla + fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dtrmm BLAS} +\pagehead{dtrmm}{dtrmm} +%\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 dtrmm (side uplo transa diag m n alpha a lda b ldb$) + (declare (type (array double-float (*)) b a) + (type (double-float) alpha) + (type fixnum ldb$ lda n m) + (type (simple-array character (*)) diag transa uplo side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (uplo character uplo-%data% uplo-%offset%) + (transa character transa-%data% transa-%offset%) + (diag character diag-%data% diag-%offset%) + (a double-float a-%data% a-%offset%) + (b double-float b-%data% b-%offset%)) + (prog ((temp 0.0) (i 0) (info 0) (j 0) (k 0) (nrowa 0) (lside nil) + (nounit nil) (upper nil)) + (declare (type (double-float) temp) + (type fixnum i info j k nrowa) + (type (member t nil) lside nounit upper)) + (setf lside (lsame side "L")) + (cond + (lside + (setf nrowa m)) + (t + (setf nrowa n))) + (setf nounit (lsame diag "N")) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not lside) (not (lsame side "R"))) + (setf info 1)) + ((and (not upper) (not (lsame uplo "L"))) + (setf info 2)) + ((and (not (lsame transa "N")) + (not (lsame transa "T")) + (not (lsame transa "C"))) + (setf info 3)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 4)) + ((< m 0) + (setf info 5)) + ((< n 0) + (setf info 6)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 9)) + ((< ldb$ (max (the fixnum 1) (the fixnum m))) + (setf info 11))) + (cond + ((/= info 0) + (xerbla "DTRMM " info) + (go end_label))) + (if (= n 0) (go end_label)) + (cond + ((= alpha 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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + zero))))) + (go end_label))) + (cond + (lside + (cond + ((lsame transa "N") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add k + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (+ + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + temp)))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (k m + (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + temp) + (if nounit + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add k 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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%))))))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i m + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add i + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha temp))))))) + (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 + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) + (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha temp))))))))))) + (t + (cond + ((lsame transa "N") + (cond + (upper + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp alpha) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (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%) + (* temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%))) + (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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp alpha) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (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%) + (* temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))) + (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) + (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%))) + (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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%))) + (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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (setf temp alpha) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (cond + ((/= temp one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (t + (f2cl-lib:fdo (k n (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k 1) nil) + (tagbody + (f2cl-lib:fdo (j (f2cl-lib:int-add k 1) + (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%))) + (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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (setf temp alpha) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (cond + ((/= temp one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))))))))))) + 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::dtrmm 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 fixnum + (double-float) (array double-float (*)) + fixnum (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{dtrmv BLAS} +\pagehead{dtrmv}{dtrmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dtrmv (uplo trans diag n a lda x incx) + (declare (type (array double-float (*)) x a) + (type fixnum incx lda n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (a double-float a-%data% a-%offset%) + (x double-float x-%data% x-%offset%)) + (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (kx 0) (temp 0.0)) + (declare (type (member t nil) nounit) + (type fixnum i info ix j jx kx) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info 6)) + ((= incx 0) + (setf info 8))) + (cond + ((/= info 0) + (xerbla "DTRMV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))))))) + (t + (setf jx kx) + (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 + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf jx (f2cl-lib:int-add jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf jx (f2cl-lib:int-sub jx incx))))))))) + (t + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) 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 x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix jx) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (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 (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) 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 x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix jx) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (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 (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)))))))))) + end_label + (return (values 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::dtrmv 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)) + fixnum (array double-float (*)) + fixnum (array double-float (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dtrsm BLAS} +\pagehead{dtrsm}{dtrsm} +%\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 dtrsm (side uplo transa diag m n alpha a lda b ldb$) + (declare (type (array double-float (*)) b a) + (type (double-float) alpha) + (type fixnum ldb$ lda n m) + (type (simple-array character (*)) diag transa uplo side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (uplo character uplo-%data% uplo-%offset%) + (transa character transa-%data% transa-%offset%) + (diag character diag-%data% diag-%offset%) + (a double-float a-%data% a-%offset%) + (b double-float b-%data% b-%offset%)) + (prog ((temp 0.0) (i 0) (info 0) (j 0) (k 0) (nrowa 0) (lside nil) + (nounit nil) (upper nil)) + (declare (type (double-float) temp) + (type fixnum i info j k nrowa) + (type (member t nil) lside nounit upper)) + (setf lside (lsame side "L")) + (cond + (lside + (setf nrowa m)) + (t + (setf nrowa n))) + (setf nounit (lsame diag "N")) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not lside) (not (lsame side "R"))) + (setf info 1)) + ((and (not upper) (not (lsame uplo "L"))) + (setf info 2)) + ((and (not (lsame transa "N")) + (not (lsame transa "T")) + (not (lsame transa "C"))) + (setf info 3)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 4)) + ((< m 0) + (setf info 5)) + ((< n 0) + (setf info 6)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 9)) + ((< ldb$ (max (the fixnum 1) (the fixnum m))) + (setf info 11))) + (cond + ((/= info 0) + (xerbla "DTRSM " info) + (go end_label))) + (if (= n 0) (go end_label)) + (cond + ((= alpha 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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + zero))))) + (go end_label))) + (cond + (lside + (cond + ((lsame transa "N") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= alpha one) + (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%) + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (k m + (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) + (if nounit + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (/ + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add k + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (- + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%))))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= alpha one) + (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%) + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) + (if nounit + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (/ + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add k 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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%))))))))))))))) + (t + (cond + (upper + (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 + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add i + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + temp)))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i m + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) + (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + temp)))))))))) + (t + (cond + ((lsame transa "N") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= alpha one) + (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%) + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) + (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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (cond + (nounit + (setf temp + (/ one + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))) + (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%) + (* temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (t + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= alpha one) + (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%) + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) + (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) + (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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (cond + (nounit + (setf temp + (/ one + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))) + (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%) + (* temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (k n (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k 1) nil) + (tagbody + (cond + (nounit + (setf temp + (/ one + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) + (setf temp + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)) + (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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (cond + ((/= alpha one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (t + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + (nounit + (setf temp + (/ one + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (j (f2cl-lib:int-add k 1) + (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) + (setf temp + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)) + (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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (cond + ((/= alpha one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))))))))))) + 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::dtrsm 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 fixnum + (double-float) (array double-float (*)) + fixnum (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{dtrsna LAPACK} +\pagehead{dtrsna}{dtrsna} +%\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)) + (defun dtrsna + (job howmny select n t$ ldt vl ldvl vr ldvr s sep mm m work ldwork + iwork info) + (declare (type (array fixnum (*)) iwork) + (type (array double-float (*)) work sep s vr vl t$) + (type fixnum info ldwork m mm ldvr ldvl ldt n) + (type (array (member t nil) (*)) select) + (type (simple-array character (*)) howmny job)) + (f2cl-lib:with-multi-array-data + ((job character job-%data% job-%offset%) + (howmny character howmny-%data% howmny-%offset%) + (select (member t nil) select-%data% select-%offset%) + (t$ double-float t$-%data% t$-%offset%) + (vl double-float vl-%data% vl-%offset%) + (vr double-float vr-%data% vr-%offset%) + (s double-float s-%data% s-%offset%) + (sep double-float sep-%data% sep-%offset%) + (work double-float work-%data% work-%offset%) + (iwork fixnum iwork-%data% iwork-%offset%)) + (prog ((dummy (make-array 1 :element-type 'double-float)) (bignum 0.0) + (cond$ 0.0) (cs 0.0) (delta 0.0) (dumm 0.0) (eps 0.0) (est 0.0) + (lnrm 0.0) (mu 0.0) (prod 0.0) (prod1 0.0) (prod2 0.0) (rnrm 0.0) + (scale 0.0) (smlnum 0.0) (sn 0.0) (i 0) (ierr 0) (ifst 0) (ilst 0) + (j 0) (k 0) (kase 0) (ks 0) (n2 0) (nn 0) (pair nil) (somcon nil) + (wantbh nil) (wants nil) (wantsp nil) (/=$ 0.0f0)) + (declare (type (single-float) /=$) + (type (array double-float (1)) dummy) + (type (double-float) bignum cond$ cs delta dumm eps est lnrm + mu prod prod1 prod2 rnrm scale smlnum sn) + (type fixnum i ierr ifst ilst j k kase ks n2 nn) + (type (member t nil) pair somcon wantbh wants wantsp)) + (setf wantbh (lsame job "B")) + (setf wants (or (lsame job "E") wantbh)) + (setf wantsp (or (lsame job "V") wantbh)) + (setf somcon (lsame howmny "S")) + (setf info 0) + (cond + ((and (not wants) (not wantsp)) + (setf info -1)) + ((and (not (lsame howmny "A")) (not somcon)) + (setf info -2)) + ((< n 0) + (setf info -4)) + ((< ldt (max (the fixnum 1) (the fixnum n))) + (setf info -6)) + ((or (< ldvl 1) (and wants (< ldvl n))) + (setf info -8)) + ((or (< ldvr 1) (and wants (< ldvr n))) + (setf info -10)) + (t + (cond + (somcon + (setf m 0) + (setf pair nil) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + (pair + (setf pair nil)) + (t + (cond + ((< k n) + (cond + ((= + (f2cl-lib:fref t$ + ((f2cl-lib:int-add k 1) k) + ((1 ldt) (1 *))) + zero) + (if + (f2cl-lib:fref select-%data% + (k) + ((1 *)) + select-%offset%) + (setf m (f2cl-lib:int-add m 1)))) + (t + (setf pair t) + (if + (or + (f2cl-lib:fref select-%data% + (k) + ((1 *)) + select-%offset%) + (f2cl-lib:fref select-%data% + ((f2cl-lib:int-add k 1)) + ((1 *)) + select-%offset%)) + (setf m (f2cl-lib:int-add m 2)))))) + (t + (if + (f2cl-lib:fref select-%data% + (n) + ((1 *)) + select-%offset%) + (setf m (f2cl-lib:int-add m 1)))))))))) + (t + (setf m n))) + (cond + ((< mm m) + (setf info -13)) + ((or (< ldwork 1) (and wantsp (< ldwork n))) + (setf info -16))))) + (cond + ((/= info 0) + (xerbla "DTRSNA" (f2cl-lib:int-sub info)) + (go end_label))) + (if (= n 0) (go end_label)) + (cond + ((= n 1) + (cond + (somcon + (if + (not (f2cl-lib:fref select-%data% (1) ((1 *)) select-%offset%)) + (go end_label)))) + (if wants (setf (f2cl-lib:fref s-%data% (1) ((1 *)) s-%offset%) one)) + (if wantsp + (setf (f2cl-lib:fref sep-%data% (1) ((1 *)) sep-%offset%) + (abs + (f2cl-lib:fref t$-%data% + (1 1) + ((1 ldt) (1 *)) + t$-%offset%)))) + (go end_label))) + (setf eps (dlamch "P")) + (setf smlnum (/ (dlamch "S") eps)) + (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 ks 0) + (setf pair nil) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + (pair + (setf pair nil) + (go label60)) + (t + (if (< k n) + (setf pair + (coerce + (/= + (f2cl-lib:fref t$-%data% + ((f2cl-lib:int-add k 1) k) + ((1 ldt) (1 *)) + t$-%offset%) + zero) + '(member t nil)))))) + (cond + (somcon + (cond + (pair + (if + (and + (not + (f2cl-lib:fref select-%data% (k) ((1 *)) select-%offset%)) + (not + (f2cl-lib:fref select-%data% + ((f2cl-lib:int-add k 1)) + ((1 *)) + select-%offset%))) + (go label60))) + (t + (if + (not + (f2cl-lib:fref select-%data% (k) ((1 *)) select-%offset%)) + (go label60)))))) + (setf ks (f2cl-lib:int-add ks 1)) + (cond + (wants + (cond + ((not pair) + (setf prod + (ddot n + (f2cl-lib:array-slice vr + double-float + (1 ks) + ((1 ldvr) (1 *))) + 1 + (f2cl-lib:array-slice vl + double-float + (1 ks) + ((1 ldvl) (1 *))) + 1)) + (setf rnrm + (dnrm2 n + (f2cl-lib:array-slice vr + double-float + (1 ks) + ((1 ldvr) (1 *))) + 1)) + (setf lnrm + (dnrm2 n + (f2cl-lib:array-slice vl + double-float + (1 ks) + ((1 ldvl) (1 *))) + 1)) + (setf (f2cl-lib:fref s-%data% (ks) ((1 *)) s-%offset%) + (/ (abs prod) (* rnrm lnrm)))) + (t + (setf prod1 + (ddot n + (f2cl-lib:array-slice vr + double-float + (1 ks) + ((1 ldvr) (1 *))) + 1 + (f2cl-lib:array-slice vl + double-float + (1 ks) + ((1 ldvl) (1 *))) + 1)) + (setf prod1 + (+ prod1 + (ddot n + (f2cl-lib:array-slice vr + double-float + (1 (f2cl-lib:int-add ks 1)) + ((1 ldvr) (1 *))) + 1 + (f2cl-lib:array-slice vl + double-float + (1 (f2cl-lib:int-add ks 1)) + ((1 ldvl) (1 *))) + 1))) + (setf prod2 + (ddot n + (f2cl-lib:array-slice vl + double-float + (1 ks) + ((1 ldvl) (1 *))) + 1 + (f2cl-lib:array-slice vr + double-float + (1 (f2cl-lib:int-add ks 1)) + ((1 ldvr) (1 *))) + 1)) + (setf prod2 + (- prod2 + (ddot n + (f2cl-lib:array-slice vl + double-float + (1 (f2cl-lib:int-add ks 1)) + ((1 ldvl) (1 *))) + 1 + (f2cl-lib:array-slice vr + double-float + (1 ks) + ((1 ldvr) (1 *))) + 1))) + (setf rnrm + (dlapy2 + (dnrm2 n + (f2cl-lib:array-slice vr + double-float + (1 ks) + ((1 ldvr) (1 *))) + 1) + (dnrm2 n + (f2cl-lib:array-slice vr + double-float + (1 (f2cl-lib:int-add ks 1)) + ((1 ldvr) (1 *))) + 1))) + (setf lnrm + (dlapy2 + (dnrm2 n + (f2cl-lib:array-slice vl + double-float + (1 ks) + ((1 ldvl) (1 *))) + 1) + (dnrm2 n + (f2cl-lib:array-slice vl + double-float + (1 (f2cl-lib:int-add ks 1)) + ((1 ldvl) (1 *))) + 1))) + (setf cond$ (/ (dlapy2 prod1 prod2) (* rnrm lnrm))) + (setf (f2cl-lib:fref s-%data% (ks) ((1 *)) s-%offset%) cond$) + (setf (f2cl-lib:fref s-%data% + ((f2cl-lib:int-add ks 1)) + ((1 *)) + s-%offset%) + cond$))))) + (cond + (wantsp + (dlacpy "Full" n n t$ ldt work ldwork) + (setf ifst k) + (setf ilst 1) + (multiple-value-bind + (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 + var-9) + (dtrexc "No Q" n work ldwork dummy 1 ifst ilst + (f2cl-lib:array-slice work + double-float + (1 (f2cl-lib:int-add n 1)) + ((1 ldwork) (1 *))) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-8)) + (setf ifst var-6) + (setf ilst var-7) + (setf ierr var-9)) + (cond + ((or (= ierr 1) (= ierr 2)) + (setf scale one) + (setf est bignum)) + (t + (tagbody + (cond + ((= (f2cl-lib:fref work (2 1) ((1 ldwork) (1 *))) zero) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% + (i i) + ((1 ldwork) (1 *)) + work-%offset%) + (- + (f2cl-lib:fref work-%data% + (i i) + ((1 ldwork) (1 *)) + work-%offset%) + (f2cl-lib:fref work-%data% + (1 1) + ((1 ldwork) (1 *)) + work-%offset%))))) + (setf n2 1) + (setf nn (f2cl-lib:int-sub n 1))) + (t + (setf mu + (* + (f2cl-lib:fsqrt + (abs + (f2cl-lib:fref work-%data% + (1 2) + ((1 ldwork) (1 *)) + work-%offset%))) + (f2cl-lib:fsqrt + (abs + (f2cl-lib:fref work-%data% + (2 1) + ((1 ldwork) (1 *)) + work-%offset%))))) + (setf delta + (dlapy2 mu + (f2cl-lib:fref work-%data% + (2 1) + ((1 ldwork) (1 *)) + work-%offset%))) + (setf cs (/ mu delta)) + (setf sn + (/ + (- + (f2cl-lib:fref work-%data% + (2 1) + ((1 ldwork) (1 *)) + work-%offset%)) + delta)) + (f2cl-lib:fdo (j 3 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% + (2 j) + ((1 ldwork) (1 *)) + work-%offset%) + (* cs + (f2cl-lib:fref work-%data% + (2 j) + ((1 ldwork) (1 *)) + work-%offset%))) + (setf (f2cl-lib:fref work-%data% + (j j) + ((1 ldwork) (1 *)) + work-%offset%) + (- + (f2cl-lib:fref work-%data% + (j j) + ((1 ldwork) (1 *)) + work-%offset%) + (f2cl-lib:fref work-%data% + (1 1) + ((1 ldwork) (1 *)) + work-%offset%))))) + (setf (f2cl-lib:fref work-%data% + (2 2) + ((1 ldwork) (1 *)) + work-%offset%) + zero) + (setf (f2cl-lib:fref work-%data% + (1 (f2cl-lib:int-add n 1)) + ((1 ldwork) (1 *)) + work-%offset%) + (* two mu)) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add n + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref work-%data% + (i (f2cl-lib:int-add n 1)) + ((1 ldwork) (1 *)) + work-%offset%) + (* sn + (f2cl-lib:fref work-%data% + (1 (f2cl-lib:int-add i 1)) + ((1 ldwork) (1 *)) + work-%offset%))))) + (setf n2 2) + (setf nn (f2cl-lib:int-mul 2 (f2cl-lib:int-sub n 1))))) + (setf est zero) + (setf kase 0) + label50 + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5) + (dlacon nn + (f2cl-lib:array-slice work + double-float + (1 (f2cl-lib:int-add n 2)) + ((1 ldwork) (1 *))) + (f2cl-lib:array-slice work + double-float + (1 (f2cl-lib:int-add n 4)) + ((1 ldwork) (1 *))) + iwork est kase) + (declare (ignore var-0 var-1 var-2 var-3)) + (setf est var-4) + (setf kase var-5)) + (cond + ((/= kase 0) + (cond + ((= kase 1) + (cond + ((= n2 1) + (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) + (dlaqtr t t + (f2cl-lib:int-sub n 1) + (f2cl-lib:array-slice work + double-float + (2 2) + ((1 ldwork) (1 *))) + ldwork dummy dumm scale + (f2cl-lib:array-slice work + double-float + (1 + (f2cl-lib:int-add n + 4)) + ((1 ldwork) (1 *))) + (f2cl-lib:array-slice work + double-float + (1 + (f2cl-lib:int-add n + 6)) + ((1 ldwork) (1 *))) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 + var-5 var-6 var-8 var-9)) + (setf scale var-7) + (setf ierr var-10))) + (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) + (dlaqtr t nil + (f2cl-lib:int-sub n 1) + (f2cl-lib:array-slice work + double-float + (2 2) + ((1 ldwork) (1 *))) + ldwork + (f2cl-lib:array-slice work + double-float + (1 + (f2cl-lib:int-add n + 1)) + ((1 ldwork) (1 *))) + mu scale + (f2cl-lib:array-slice work + double-float + (1 + (f2cl-lib:int-add n + 4)) + ((1 ldwork) (1 *))) + (f2cl-lib:array-slice work + double-float + (1 + (f2cl-lib:int-add n + 6)) + ((1 ldwork) (1 *))) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 + var-5 var-6 var-8 var-9)) + (setf scale var-7) + (setf ierr var-10))))) + (t + (cond + ((= n2 1) + (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) + (dlaqtr nil t + (f2cl-lib:int-sub n 1) + (f2cl-lib:array-slice work + double-float + (2 2) + ((1 ldwork) (1 *))) + ldwork dummy dumm scale + (f2cl-lib:array-slice work + double-float + (1 + (f2cl-lib:int-add n + 4)) + ((1 ldwork) (1 *))) + (f2cl-lib:array-slice work + double-float + (1 + (f2cl-lib:int-add n + 6)) + ((1 ldwork) (1 *))) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 + var-5 var-6 var-8 var-9)) + (setf scale var-7) + (setf ierr var-10))) + (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) + (dlaqtr nil nil + (f2cl-lib:int-sub n 1) + (f2cl-lib:array-slice work + double-float + (2 2) + ((1 ldwork) (1 *))) + ldwork + (f2cl-lib:array-slice work + double-float + (1 + (f2cl-lib:int-add n + 1)) + ((1 ldwork) (1 *))) + mu scale + (f2cl-lib:array-slice work + double-float + (1 + (f2cl-lib:int-add n + 4)) + ((1 ldwork) (1 *))) + (f2cl-lib:array-slice work + double-float + (1 + (f2cl-lib:int-add n + 6)) + ((1 ldwork) (1 *))) + ierr) + (declare (ignore var-0 var-1 var-2 var-3 var-4 + var-5 var-6 var-8 var-9)) + (setf scale var-7) + (setf ierr var-10)))))) + (go label50)))))) + (setf (f2cl-lib:fref sep-%data% (ks) ((1 *)) sep-%offset%) + (/ scale (max est smlnum))) + (if pair + (setf (f2cl-lib:fref sep-%data% + ((f2cl-lib:int-add ks 1)) + ((1 *)) + sep-%offset%) + (f2cl-lib:fref sep-%data% + (ks) + ((1 *)) + sep-%offset%))))) + (if pair (setf ks (f2cl-lib:int-add ks 1))) + label60)) + end_label + (return + (values nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + m + 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::dtrsna + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + (simple-array character (1)) + (array (member t nil) (*)) + fixnum (array double-float (*)) + fixnum (array double-float (*)) + fixnum (array double-float (*)) + fixnum (array double-float (*)) + (array double-float (*)) fixnum + 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::m nil nil nil + fortran-to-lisp::info) + :calls '(fortran-to-lisp::dlaqtr fortran-to-lisp::dlacon + fortran-to-lisp::dtrexc fortran-to-lisp::dlacpy + fortran-to-lisp::dlapy2 fortran-to-lisp::dnrm2 + fortran-to-lisp::ddot fortran-to-lisp::dlabad + fortran-to-lisp::dlamch fortran-to-lisp::xerbla + fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dtrsv BLAS} +\pagehead{dtrsv}{dtrsv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dtrsv (uplo trans diag n a lda x incx) + (declare (type (array double-float (*)) x a) + (type fixnum incx lda n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (a double-float a-%data% a-%offset%) + (x double-float x-%data% x-%offset%)) + (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (kx 0) (temp 0.0)) + (declare (type (member t nil) nounit) + (type fixnum i info ix j jx kx) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info 6)) + ((= incx 0) + (setf info 8))) + (cond + ((/= info 0) + (xerbla "DTRSV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%))))))))))) + (t + (setf jx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix jx) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))))) + (setf jx (f2cl-lib:int-sub jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%))))))))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix jx) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))))) + (setf jx (f2cl-lib:int-add jx incx))))))))) + (t + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + 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%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + 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)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) 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%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) 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-sub ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx)))))))))) + end_label + (return (values 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::dtrsv 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)) + fixnum (array double-float (*)) + fixnum (array double-float (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dzasum BLAS} +\pagehead{dzasum}{dzasum} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +Computes (complex double-float) $asum \leftarrow ||re(x)||_1 + ||im(x)||_1$ + +Arguments are: +\begin{itemize} +\item n - fixnum +\item dx - array (complex double-float) +\item incx - fixnum +\end{itemize} + +Return values are: +\begin{itemize} +\item 1 nil +\item 2 nil +\item 3 nil +\end{itemize} + +<>= +(defun dzasum (n zx incx) + (declare (type (array (complex double-float) (*)) zx) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((zx (complex double-float) zx-%data% zx-%offset%)) + (prog ((i 0) (ix 0) (stemp 0.0) (dzasum 0.0)) + (declare (type (double-float) dzasum stemp) + (type fixnum ix i)) + (setf dzasum 0.0) + (setf stemp 0.0) + (if (or (<= n 0) (<= incx 0)) (go end_label)) + (if (= incx 1) (go label20)) + (setf ix 1) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf stemp + (+ stemp + (dcabs1 + (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (setf dzasum stemp) + (go end_label) + label20 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf stemp + (+ stemp + (dcabs1 + (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%)))))) + (setf dzasum stemp) + end_label + (return (values dzasum 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::dzasum + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil) + :calls '(fortran-to-lisp::dcabs1)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dznrm2 BLAS} +\pagehead{dznrm2}{dznrm2} +%\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 dznrm2 (n x incx) + (declare (type (array (complex double-float) (*)) x) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((x (complex double-float) x-%data% x-%offset%)) + (prog ((norm 0.0) (scale 0.0) (ssq 0.0) (temp 0.0) (ix 0) (dznrm2 0.0)) + (declare (type fixnum ix) + (type (double-float) norm scale ssq temp dznrm2)) + (cond + ((or (< n 1) (< incx 1)) + (setf norm zero)) + (t + (setf scale zero) + (setf ssq one) + (f2cl-lib:fdo (ix 1 (f2cl-lib:int-add ix incx)) + ((> ix + (f2cl-lib:int-add 1 + (f2cl-lib:int-mul + (f2cl-lib:int-add n + (f2cl-lib:int-sub 1)) + incx))) + nil) + (tagbody + (cond + ((/= + (coerce (realpart (f2cl-lib:fref x (ix) ((1 *)))) 'double-float) + zero) + (setf temp + (abs + (coerce (realpart + (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%)) + 'double-float))) + (cond + ((< scale temp) + (setf ssq (+ one (* ssq (expt (/ scale temp) 2)))) + (setf scale temp)) + (t + (setf ssq (+ ssq (expt (/ temp scale) 2))))))) + (cond + ((/= (f2cl-lib:dimag (f2cl-lib:fref x (ix) ((1 *)))) zero) + (setf temp + (abs + (f2cl-lib:dimag + (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%)))) + (cond + ((< scale temp) + (setf ssq (+ one (* ssq (expt (/ scale temp) 2)))) + (setf scale temp)) + (t + (setf ssq (+ ssq (expt (/ temp scale) 2))))))))) + (setf norm (* scale (f2cl-lib:fsqrt ssq))))) + (setf dznrm2 norm) + end_label + (return (values dznrm2 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::dznrm2 + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter E} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter F} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter G} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter H} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter I} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{icamax BLAS} +\pagehead{icamax}{icamax} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun icamax (n cx incx) + (declare (type (array (complex single-float) (*)) cx) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((cx (complex single-float) cx-%data% cx-%offset%)) + (labels ((cabs1 (zdum) + (+ (abs (coerce (realpart zdum) 'single-float)) + (abs (f2cl-lib:aimag zdum))))) + (declare (ftype (function (complex single-float) + (values single-float &rest t)) + cabs1)) + (prog ((zdum #C(0.0f0 0.0f0)) (i 0) (ix 0) (smax 0.0f0) (icamax 0)) + (declare (type (single-float) smax) + (type fixnum icamax ix i) + (type (complex single-float) zdum)) + (setf icamax 0) + (if (or (< n 1) (<= incx 0)) (go end_label)) + (setf icamax 1) + (if (= n 1) (go end_label)) + (if (= incx 1) (go label20)) + (setf ix 1) + (setf smax (cabs1 (f2cl-lib:fref cx-%data% (1) ((1 *)) cx-%offset%))) + (setf ix (f2cl-lib:int-add ix incx)) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (if + (<= (cabs1 (f2cl-lib:fref cx-%data% (ix) ((1 *)) cx-%offset%)) + smax) + (go label5)) + (setf icamax i) + (setf smax + (cabs1 (f2cl-lib:fref cx-%data% (ix) ((1 *)) cx-%offset%))) + label5 + (setf ix (f2cl-lib:int-add ix incx)))) + (go end_label) + label20 + (setf smax (cabs1 (f2cl-lib:fref cx-%data% (1) ((1 *)) cx-%offset%))) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (if + (<= (cabs1 (f2cl-lib:fref cx-%data% (i) ((1 *)) cx-%offset%)) + smax) + (go label30)) + (setf icamax i) + (setf smax + (cabs1 (f2cl-lib:fref cx-%data% (i) ((1 *)) cx-%offset%))) + label30)) + end_label + (return (values icamax 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::icamax + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum + (array (complex single-float) (*)) + fixnum) + :return-values '(nil nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{idamax BLAS} +\pagehead{idamax}{idamax} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun idamax (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) (ix 0) (dmax 0.0) (idamax 0)) + (declare (type (double-float) dmax) + (type fixnum idamax ix i)) + (setf idamax 0) + (if (or (< n 1) (<= incx 0)) (go end_label)) + (setf idamax 1) + (if (= n 1) (go end_label)) + (if (= incx 1) (go label20)) + (setf ix 1) + (setf dmax + (the double-float (abs + (the double-float + (f2cl-lib:fref dx-%data% (1) ((1 *)) dx-%offset%))))) + (setf ix (f2cl-lib:int-add ix incx)) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (if + (<= + (the double-float (abs + (the double-float + (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%)))) + dmax) + (go label5)) + (setf idamax i) + (setf dmax + (the double-float (abs + (the double-float + (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%))))) + label5 + (setf ix (f2cl-lib:int-add ix incx)))) + (go end_label) + label20 + (setf dmax + (the double-float (abs + (the double-float + (f2cl-lib:fref dx-%data% (1) ((1 *)) dx-%offset%))))) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (if + (<= + (the double-float (abs + (the double-float + (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)))) + dmax) + (go label30)) + (setf idamax i) + (setf dmax + (the double-float (abs + (the double-float + (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%))))) + label30)) + end_label + (return (values idamax 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::idamax + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum (array double-float (*)) + fixnum) + :return-values '(nil nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ieeeck LAPACK} +\pagehead{ieeeck}{ieeeck} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun ieeeck (ispec zero one) + (declare (type (single-float) one zero) (type fixnum ispec)) + (prog ((nan1 0.0f0) (nan2 0.0f0) (nan3 0.0f0) (nan4 0.0f0) (nan5 0.0f0) + (nan6 0.0f0) (neginf 0.0f0) (negzro 0.0f0) (newzro 0.0f0) + (posinf 0.0f0) (ieeeck 0)) + (declare (type fixnum ieeeck) + (type (single-float) posinf newzro negzro neginf nan6 nan5 nan4 + nan3 nan2 nan1)) + (setf ieeeck 1) + (setf posinf (/ one zero)) + (cond + ((<= posinf one) + (setf ieeeck 0) + (go end_label))) + (setf neginf (/ (- one) zero)) + (cond + ((>= neginf zero) + (setf ieeeck 0) + (go end_label))) + (setf negzro (/ one (+ neginf one))) + (cond + ((/= negzro zero) + (setf ieeeck 0) + (go end_label))) + (setf neginf (/ one negzro)) + (cond + ((>= neginf zero) + (setf ieeeck 0) + (go end_label))) + (setf newzro (+ negzro zero)) + (cond + ((/= newzro zero) + (setf ieeeck 0) + (go end_label))) + (setf posinf (/ one newzro)) + (cond + ((<= posinf one) + (setf ieeeck 0) + (go end_label))) + (setf neginf (* neginf posinf)) + (cond + ((>= neginf zero) + (setf ieeeck 0) + (go end_label))) + (setf posinf (* posinf posinf)) + (cond + ((<= posinf one) + (setf ieeeck 0) + (go end_label))) + (if (= ispec 0) (go end_label)) + (setf nan1 (+ posinf neginf)) + (setf nan2 (/ posinf neginf)) + (setf nan3 (/ posinf posinf)) + (setf nan4 (* posinf zero)) + (setf nan5 (* neginf negzro)) + (setf nan6 (* nan5 0.0f0)) + (cond + ((= nan1 nan1) + (setf ieeeck 0) + (go end_label))) + (cond + ((= nan2 nan2) + (setf ieeeck 0) + (go end_label))) + (cond + ((= nan3 nan3) + (setf ieeeck 0) + (go end_label))) + (cond + ((= nan4 nan4) + (setf ieeeck 0) + (go end_label))) + (cond + ((= nan5 nan5) + (setf ieeeck 0) + (go end_label))) + (cond + ((= nan6 nan6) + (setf ieeeck 0) + (go end_label))) + end_label + (return (values ieeeck 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::ieeeck + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum (single-float) + (single-float)) + :return-values '(nil nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ilaenv LAPACK} +\pagehead{ilaenv}{ilaenv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun ilaenv (ispec name opts n1 n2 n3 n4) + (declare (type (simple-array character (*)) opts name) + (type fixnum n4 n3 n2 n1 ispec)) + (f2cl-lib:with-multi-array-data + ((name character name-%data% name-%offset%) + (opts character opts-%data% opts-%offset%)) + (prog ((i 0) (ic 0) (iz 0) (nb 0) (nbmin 0) (nx 0) + (subnam + (make-array '(6) :element-type 'character :initial-element #\ )) + (c3 (make-array '(3) :element-type 'character :initial-element #\ )) + (c2 (make-array '(2) :element-type 'character :initial-element #\ )) + (c4 (make-array '(2) :element-type 'character :initial-element #\ )) + (c1 (make-array '(1) :element-type 'character :initial-element #\ )) + (cname nil) (sname nil) (ilaenv 0) (char$ 0.0f0)) + (declare (type (single-float) char$) + (type (member t nil) sname cname) + (type (simple-array character (1)) c1) + (type (simple-array character (2)) c4 c2) + (type (simple-array character (3)) c3) + (type (simple-array character (6)) subnam) + (type fixnum ilaenv nx nbmin nb iz ic i)) + (f2cl-lib:computed-goto + (label100 label100 label100 label400 label500 label600 label700 label800 + label900 label1000 label1100) + ispec) + (setf ilaenv -1) + (go end_label) + label100 + (setf ilaenv 1) + (f2cl-lib:f2cl-set-string subnam name (string 6)) + (setf ic (f2cl-lib:ichar (f2cl-lib:fref-string subnam (1 1)))) + (setf iz (f2cl-lib:ichar "Z")) + (cond + ((or (= iz 90) (= iz 122)) + (cond + ((and (>= ic 97) (<= ic 122)) + (f2cl-lib:fset-string (f2cl-lib:fref-string subnam (1 1)) + (code-char (f2cl-lib:int-sub ic 32))) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i 6) nil) + (tagbody + (setf ic (f2cl-lib:ichar (f2cl-lib:fref-string subnam (i i)))) + (if (and (>= ic 97) (<= ic 122)) + (f2cl-lib:fset-string (f2cl-lib:fref-string subnam (i i)) + (code-char + (f2cl-lib:int-sub ic 32))))))))) + ((or (= iz 233) (= iz 169)) + (cond + ((or (and (>= ic 129) (<= ic 137)) + (and (>= ic 145) (<= ic 153)) + (and (>= ic 162) (<= ic 169))) + (f2cl-lib:fset-string (f2cl-lib:fref-string subnam (1 1)) + (code-char (f2cl-lib:int-add ic 64))) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i 6) nil) + (tagbody + (setf ic (f2cl-lib:ichar (f2cl-lib:fref-string subnam (i i)))) + (if + (or (and (>= ic 129) (<= ic 137)) + (and (>= ic 145) (<= ic 153)) + (and (>= ic 162) (<= ic 169))) + (f2cl-lib:fset-string (f2cl-lib:fref-string subnam (i i)) + (code-char + (f2cl-lib:int-add ic 64))))))))) + ((or (= iz 218) (= iz 250)) + (cond + ((and (>= ic 225) (<= ic 250)) + (f2cl-lib:fset-string (f2cl-lib:fref-string subnam (1 1)) + (code-char (f2cl-lib:int-sub ic 32))) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i 6) nil) + (tagbody + (setf ic (f2cl-lib:ichar (f2cl-lib:fref-string subnam (i i)))) + (if (and (>= ic 225) (<= ic 250)) + (f2cl-lib:fset-string (f2cl-lib:fref-string subnam (i i)) + (code-char + (f2cl-lib:int-sub ic 32)))))))))) + (f2cl-lib:f2cl-set-string c1 + (f2cl-lib:fref-string subnam (1 1)) + (string 1)) + (setf sname (or (f2cl-lib:fstring-= c1 "S") (f2cl-lib:fstring-= c1 "D"))) + (setf cname (or (f2cl-lib:fstring-= c1 "C") (f2cl-lib:fstring-= c1 "Z"))) + (if (not (or cname sname)) (go end_label)) + (f2cl-lib:f2cl-set-string c2 + (f2cl-lib:fref-string subnam (2 3)) + (string 2)) + (f2cl-lib:f2cl-set-string c3 + (f2cl-lib:fref-string subnam (4 6)) + (string 3)) + (f2cl-lib:f2cl-set-string c4 (f2cl-lib:fref-string c3 (2 3)) (string 2)) + (f2cl-lib:computed-goto (label110 label200 label300) ispec) + label110 + (setf nb 1) + (cond + ((f2cl-lib:fstring-= c2 "GE") + (cond + ((f2cl-lib:fstring-= c3 "TRF") + (cond + (sname + (setf nb 64)) + (t + (setf nb 64)))) + ((or (f2cl-lib:fstring-= c3 "QRF") + (f2cl-lib:fstring-= c3 "RQF") + (f2cl-lib:fstring-= c3 "LQF") + (f2cl-lib:fstring-= c3 "QLF")) + (cond + (sname + (setf nb 32)) + (t + (setf nb 32)))) + ((f2cl-lib:fstring-= c3 "HRD") + (cond + (sname + (setf nb 32)) + (t + (setf nb 32)))) + ((f2cl-lib:fstring-= c3 "BRD") + (cond + (sname + (setf nb 32)) + (t + (setf nb 32)))) + ((f2cl-lib:fstring-= c3 "TRI") + (cond + (sname + (setf nb 64)) + (t + (setf nb 64)))))) + ((f2cl-lib:fstring-= c2 "PO") + (cond + ((f2cl-lib:fstring-= c3 "TRF") + (cond + (sname + (setf nb 64)) + (t + (setf nb 64)))))) + ((f2cl-lib:fstring-= c2 "SY") + (cond + ((f2cl-lib:fstring-= c3 "TRF") + (cond + (sname + (setf nb 64)) + (t + (setf nb 64)))) + ((and sname (f2cl-lib:fstring-= c3 "TRD")) + (setf nb 32)) + ((and sname (f2cl-lib:fstring-= c3 "GST")) + (setf nb 64)))) + ((and cname (f2cl-lib:fstring-= c2 "HE")) + (cond + ((f2cl-lib:fstring-= c3 "TRF") + (setf nb 64)) + ((f2cl-lib:fstring-= c3 "TRD") + (setf nb 32)) + ((f2cl-lib:fstring-= c3 "GST") + (setf nb 64)))) + ((and sname (f2cl-lib:fstring-= c2 "OR")) + (cond + ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "G") + (cond + ((or (f2cl-lib:fstring-= c4 "QR") + (f2cl-lib:fstring-= c4 "RQ") + (f2cl-lib:fstring-= c4 "LQ") + (f2cl-lib:fstring-= c4 "QL") + (f2cl-lib:fstring-= c4 "HR") + (f2cl-lib:fstring-= c4 "TR") + (f2cl-lib:fstring-= c4 "BR")) + (setf nb 32)))) + ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "M") + (cond + ((or (f2cl-lib:fstring-= c4 "QR") + (f2cl-lib:fstring-= c4 "RQ") + (f2cl-lib:fstring-= c4 "LQ") + (f2cl-lib:fstring-= c4 "QL") + (f2cl-lib:fstring-= c4 "HR") + (f2cl-lib:fstring-= c4 "TR") + (f2cl-lib:fstring-= c4 "BR")) + (setf nb 32)))))) + ((and cname (f2cl-lib:fstring-= c2 "UN")) + (cond + ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "G") + (cond + ((or (f2cl-lib:fstring-= c4 "QR") + (f2cl-lib:fstring-= c4 "RQ") + (f2cl-lib:fstring-= c4 "LQ") + (f2cl-lib:fstring-= c4 "QL") + (f2cl-lib:fstring-= c4 "HR") + (f2cl-lib:fstring-= c4 "TR") + (f2cl-lib:fstring-= c4 "BR")) + (setf nb 32)))) + ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "M") + (cond + ((or (f2cl-lib:fstring-= c4 "QR") + (f2cl-lib:fstring-= c4 "RQ") + (f2cl-lib:fstring-= c4 "LQ") + (f2cl-lib:fstring-= c4 "QL") + (f2cl-lib:fstring-= c4 "HR") + (f2cl-lib:fstring-= c4 "TR") + (f2cl-lib:fstring-= c4 "BR")) + (setf nb 32)))))) + ((f2cl-lib:fstring-= c2 "GB") + (cond + ((f2cl-lib:fstring-= c3 "TRF") + (cond + (sname + (cond + ((<= n4 64) + (setf nb 1)) + (t + (setf nb 32)))) + (t + (cond + ((<= n4 64) + (setf nb 1)) + (t + (setf nb 32)))))))) + ((f2cl-lib:fstring-= c2 "PB") + (cond + ((f2cl-lib:fstring-= c3 "TRF") + (cond + (sname + (cond + ((<= n2 64) + (setf nb 1)) + (t + (setf nb 32)))) + (t + (cond + ((<= n2 64) + (setf nb 1)) + (t + (setf nb 32)))))))) + ((f2cl-lib:fstring-= c2 "TR") + (cond + ((f2cl-lib:fstring-= c3 "TRI") + (cond + (sname + (setf nb 64)) + (t + (setf nb 64)))))) + ((f2cl-lib:fstring-= c2 "LA") + (cond + ((f2cl-lib:fstring-= c3 "UUM") + (cond + (sname + (setf nb 64)) + (t + (setf nb 64)))))) + ((and sname (f2cl-lib:fstring-= c2 "ST")) + (cond + ((f2cl-lib:fstring-= c3 "EBZ") + (setf nb 1))))) + (setf ilaenv nb) + (go end_label) + label200 + (setf nbmin 2) + (cond + ((f2cl-lib:fstring-= c2 "GE") + (cond + ((or (f2cl-lib:fstring-= c3 "QRF") + (f2cl-lib:fstring-= c3 "RQF") + (f2cl-lib:fstring-= c3 "LQF") + (f2cl-lib:fstring-= c3 "QLF")) + (cond + (sname + (setf nbmin 2)) + (t + (setf nbmin 2)))) + ((f2cl-lib:fstring-= c3 "HRD") + (cond + (sname + (setf nbmin 2)) + (t + (setf nbmin 2)))) + ((f2cl-lib:fstring-= c3 "BRD") + (cond + (sname + (setf nbmin 2)) + (t + (setf nbmin 2)))) + ((f2cl-lib:fstring-= c3 "TRI") + (cond + (sname + (setf nbmin 2)) + (t + (setf nbmin 2)))))) + ((f2cl-lib:fstring-= c2 "SY") + (cond + ((f2cl-lib:fstring-= c3 "TRF") + (cond + (sname + (setf nbmin 8)) + (t + (setf nbmin 8)))) + ((and sname (f2cl-lib:fstring-= c3 "TRD")) + (setf nbmin 2)))) + ((and cname (f2cl-lib:fstring-= c2 "HE")) + (cond + ((f2cl-lib:fstring-= c3 "TRD") + (setf nbmin 2)))) + ((and sname (f2cl-lib:fstring-= c2 "OR")) + (cond + ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "G") + (cond + ((or (f2cl-lib:fstring-= c4 "QR") + (f2cl-lib:fstring-= c4 "RQ") + (f2cl-lib:fstring-= c4 "LQ") + (f2cl-lib:fstring-= c4 "QL") + (f2cl-lib:fstring-= c4 "HR") + (f2cl-lib:fstring-= c4 "TR") + (f2cl-lib:fstring-= c4 "BR")) + (setf nbmin 2)))) + ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "M") + (cond + ((or (f2cl-lib:fstring-= c4 "QR") + (f2cl-lib:fstring-= c4 "RQ") + (f2cl-lib:fstring-= c4 "LQ") + (f2cl-lib:fstring-= c4 "QL") + (f2cl-lib:fstring-= c4 "HR") + (f2cl-lib:fstring-= c4 "TR") + (f2cl-lib:fstring-= c4 "BR")) + (setf nbmin 2)))))) + ((and cname (f2cl-lib:fstring-= c2 "UN")) + (cond + ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "G") + (cond + ((or (f2cl-lib:fstring-= c4 "QR") + (f2cl-lib:fstring-= c4 "RQ") + (f2cl-lib:fstring-= c4 "LQ") + (f2cl-lib:fstring-= c4 "QL") + (f2cl-lib:fstring-= c4 "HR") + (f2cl-lib:fstring-= c4 "TR") + (f2cl-lib:fstring-= c4 "BR")) + (setf nbmin 2)))) + ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "M") + (cond + ((or (f2cl-lib:fstring-= c4 "QR") + (f2cl-lib:fstring-= c4 "RQ") + (f2cl-lib:fstring-= c4 "LQ") + (f2cl-lib:fstring-= c4 "QL") + (f2cl-lib:fstring-= c4 "HR") + (f2cl-lib:fstring-= c4 "TR") + (f2cl-lib:fstring-= c4 "BR")) + (setf nbmin 2))))))) + (setf ilaenv nbmin) + (go end_label) + label300 + (setf nx 0) + (cond + ((f2cl-lib:fstring-= c2 "GE") + (cond + ((or (f2cl-lib:fstring-= c3 "QRF") + (f2cl-lib:fstring-= c3 "RQF") + (f2cl-lib:fstring-= c3 "LQF") + (f2cl-lib:fstring-= c3 "QLF")) + (cond + (sname + (setf nx 128)) + (t + (setf nx 128)))) + ((f2cl-lib:fstring-= c3 "HRD") + (cond + (sname + (setf nx 128)) + (t + (setf nx 128)))) + ((f2cl-lib:fstring-= c3 "BRD") + (cond + (sname + (setf nx 128)) + (t + (setf nx 128)))))) + ((f2cl-lib:fstring-= c2 "SY") + (cond + ((and sname (f2cl-lib:fstring-= c3 "TRD")) + (setf nx 32)))) + ((and cname (f2cl-lib:fstring-= c2 "HE")) + (cond + ((f2cl-lib:fstring-= c3 "TRD") + (setf nx 32)))) + ((and sname (f2cl-lib:fstring-= c2 "OR")) + (cond + ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "G") + (cond + ((or (f2cl-lib:fstring-= c4 "QR") + (f2cl-lib:fstring-= c4 "RQ") + (f2cl-lib:fstring-= c4 "LQ") + (f2cl-lib:fstring-= c4 "QL") + (f2cl-lib:fstring-= c4 "HR") + (f2cl-lib:fstring-= c4 "TR") + (f2cl-lib:fstring-= c4 "BR")) + (setf nx 128)))))) + ((and cname (f2cl-lib:fstring-= c2 "UN")) + (cond + ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "G") + (cond + ((or (f2cl-lib:fstring-= c4 "QR") + (f2cl-lib:fstring-= c4 "RQ") + (f2cl-lib:fstring-= c4 "LQ") + (f2cl-lib:fstring-= c4 "QL") + (f2cl-lib:fstring-= c4 "HR") + (f2cl-lib:fstring-= c4 "TR") + (f2cl-lib:fstring-= c4 "BR")) + (setf nx 128))))))) + (setf ilaenv nx) + (go end_label) + label400 + (setf ilaenv 6) + (go end_label) + label500 + (setf ilaenv 2) + (go end_label) + label600 + (setf ilaenv + (f2cl-lib:int + (* + (coerce (realpart + (min (the fixnum n1) (the fixnum n2))) 'single-float) + 1.6f0))) + (go end_label) + label700 + (setf ilaenv 1) + (go end_label) + label800 + (setf ilaenv 50) + (go end_label) + label900 + (setf ilaenv 25) + (go end_label) + label1000 + (setf ilaenv 0) + (cond + ((= ilaenv 1) + (setf ilaenv (ieeeck 0 0.0f0 1.0f0)))) + (go end_label) + label1100 + (setf ilaenv 0) + (cond + ((= ilaenv 1) + (setf ilaenv (ieeeck 1 0.0f0 1.0f0)))) + end_label + (return (values ilaenv 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::ilaenv + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum + (simple-array character (*)) + (simple-array character (*)) + fixnum fixnum + fixnum + fixnum) + :return-values '(nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::ieeeck)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{isamax BLAS} +\pagehead{isamax}{isamax} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun isamax (n sx incx) + (declare (type (array single-float (*)) sx) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((sx single-float sx-%data% sx-%offset%)) + (prog ((i 0) (ix 0) (smax 0.0f0) (isamax 0)) + (declare (type (single-float) smax) + (type fixnum isamax ix i)) + (setf isamax 0) + (if (or (< n 1) (<= incx 0)) (go end_label)) + (setf isamax 1) + (if (= n 1) (go end_label)) + (if (= incx 1) (go label20)) + (setf ix 1) + (setf smax (abs (f2cl-lib:fref sx-%data% (1) ((1 *)) sx-%offset%))) + (setf ix (f2cl-lib:int-add ix incx)) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (if + (<= (abs (f2cl-lib:fref sx-%data% (ix) ((1 *)) sx-%offset%)) smax) + (go label5)) + (setf isamax i) + (setf smax (abs (f2cl-lib:fref sx-%data% (ix) ((1 *)) sx-%offset%))) + label5 + (setf ix (f2cl-lib:int-add ix incx)))) + (go end_label) + label20 + (setf smax (abs (f2cl-lib:fref sx-%data% (1) ((1 *)) sx-%offset%))) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (if (<= (abs (f2cl-lib:fref sx-%data% (i) ((1 *)) sx-%offset%)) smax) + (go label30)) + (setf isamax i) + (setf smax (abs (f2cl-lib:fref sx-%data% (i) ((1 *)) sx-%offset%))) + label30)) + end_label + (return (values isamax 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::isamax + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum (array single-float (*)) + fixnum) + :return-values '(nil nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{izamax BLAS} +\pagehead{izamax}{izamax} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun izamax (n zx incx) + (declare (type (array (complex double-float) (*)) zx) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((zx (complex double-float) zx-%data% zx-%offset%)) + (prog ((i 0) (ix 0) (smax 0.0) (izamax 0)) + (declare (type (double-float) smax) + (type fixnum izamax ix i)) + (setf izamax 0) + (if (or (< n 1) (<= incx 0)) (go end_label)) + (setf izamax 1) + (if (= n 1) (go end_label)) + (if (= incx 1) (go label20)) + (setf ix 1) + (setf smax (dcabs1 (f2cl-lib:fref zx-%data% (1) ((1 *)) zx-%offset%))) + (setf ix (f2cl-lib:int-add ix incx)) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (if + (<= (dcabs1 (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%)) + smax) + (go label5)) + (setf izamax i) + (setf smax + (dcabs1 (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%))) + label5 + (setf ix (f2cl-lib:int-add ix incx)))) + (go end_label) + label20 + (setf smax (dcabs1 (f2cl-lib:fref zx-%data% (1) ((1 *)) zx-%offset%))) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (if + (<= (dcabs1 (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%)) smax) + (go label30)) + (setf izamax i) + (setf smax + (dcabs1 (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%))) + label30)) + end_label + (return (values izamax 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::izamax + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil) + :calls '(fortran-to-lisp::dcabs1)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter J} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter K} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter L} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{lsame BLAS} +\pagehead{lsame}{lsame} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun lsame (ca cb) + (declare (type (simple-array character (*)) cb ca)) + (f2cl-lib:with-multi-array-data + ((ca character ca-%data% ca-%offset%) + (cb character cb-%data% cb-%offset%)) + (prog ((inta 0) (intb 0) (zcode 0) (lsame nil)) + (declare (type (member t nil) lsame) + (type fixnum zcode intb inta)) + (setf lsame (coerce (f2cl-lib:fstring-= ca cb) '(member t nil))) + (unless lsame + (setf zcode (f2cl-lib:ichar "Z")) + (setf inta (f2cl-lib:ichar ca)) + (setf intb (f2cl-lib:ichar cb)) + (cond + ((or (= zcode 90) (= zcode 122)) + (if (and (>= inta 97) (<= inta 122)) + (setf inta (f2cl-lib:int-sub inta 32))) + (if (and (>= intb 97) (<= intb 122)) + (setf intb (f2cl-lib:int-sub intb 32)))) + ((or (= zcode 233) (= zcode 169)) + (if + (or (and (>= inta 129) (<= inta 137)) + (and (>= inta 145) (<= inta 153)) + (and (>= inta 162) (<= inta 169))) + (setf inta (f2cl-lib:int-add inta 64))) + (if + (or (and (>= intb 129) (<= intb 137)) + (and (>= intb 145) (<= intb 153)) + (and (>= intb 162) (<= intb 169))) + (setf intb (f2cl-lib:int-add intb 64)))) + ((or (= zcode 218) (= zcode 250)) + (if (and (>= inta 225) (<= inta 250)) + (setf inta (f2cl-lib:int-sub inta 32))) + (if (and (>= intb 225) (<= intb 250)) + (setf intb (f2cl-lib:int-sub intb 32))))) + (setf lsame (coerce (= inta intb) '(member t nil)))) + (return (values lsame 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::lsame fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + (simple-array character (1))) + :return-values '(nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter M} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter N} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter O} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter P} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter Q} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter R} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter S} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter T} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter U} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter V} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter W} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter X} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{xerbla BLAS} +\pagehead{xerbla}{xerbla} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun xerbla (srname info) + (declare (type fixnum info) + (type (simple-array character (*)) srname)) + (f2cl-lib:with-multi-array-data + ((srname character srname-%data% srname-%offset%)) + (prog () + (declare) + (format t + " ** On entry to ~a parameter number ~a had an illegal value~%" + srname info) + (return (values 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::xerbla + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (6)) + fixnum) + :return-values '(nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter Y} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chapter Z} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zaxpy BLAS} +\pagehead{zaxpy}{zaxpy} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +Computes (complex double-float) $y \leftarrow \alpha{}x + y$ + +Arguments are: +\begin{itemize} +\item n - fixnum +\item da - (complex double-float) +\item dx - array (complex double-float) +\item incx - fixnum +\item dy - array (complex double-float) +\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 zaxpy (n za zx incx zy incy) + (declare (type (array (complex double-float) (*)) zy zx) + (type (complex double-float) za) + (type fixnum incy incx n)) + (f2cl-lib:with-multi-array-data + ((zx (complex double-float) zx-%data% zx-%offset%) + (zy (complex double-float) zy-%data% zy-%offset%)) + (prog ((i 0) (ix 0) (iy 0)) + (declare (type fixnum iy ix i)) + (if (<= n 0) (go end_label)) + (if (= (dcabs1 za) 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 zy-%data% (iy) ((1 *)) zy-%offset%) + (+ (f2cl-lib:fref zy-%data% (iy) ((1 *)) zy-%offset%) + (* za + (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (go end_label) + label20 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%) + (+ (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%) + (* za (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%)))))) + end_label + (return (values 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::zaxpy fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil nil) + :calls '(fortran-to-lisp::dcabs1)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zcopy BLAS} +\pagehead{zcopy}{zcopy} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun zcopy (n zx incx zy incy) + (declare (type (array (complex double-float) (*)) zy zx) + (type fixnum incy incx n)) + (f2cl-lib:with-multi-array-data + ((zx (complex double-float) zx-%data% zx-%offset%) + (zy (complex double-float) zy-%data% zy-%offset%)) + (prog ((i 0) (ix 0) (iy 0)) + (declare (type fixnum 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 zy-%data% (iy) ((1 *)) zy-%offset%) + (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%)) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (go end_label) + label20 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%) + (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%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::zcopy fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zdotc BLAS} +\pagehead{zdotc}{zdotc} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun zdotc (n zx incx zy incy) + (declare (type (array (complex double-float) (*)) zy zx) + (type fixnum incy incx n)) + (f2cl-lib:with-multi-array-data + ((zx (complex double-float) zx-%data% zx-%offset%) + (zy (complex double-float) zy-%data% zy-%offset%)) + (prog ((i 0) (ix 0) (iy 0) (ztemp #C(0.0 0.0)) (zdotc #C(0.0 0.0))) + (declare (type (complex double-float) zdotc ztemp) + (type fixnum iy ix i)) + (setf ztemp (complex 0.0 0.0)) + (setf zdotc (complex 0.0 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 ztemp + (+ ztemp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%)) + (f2cl-lib:fref zy-%data% (iy) ((1 *)) zy-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (setf zdotc ztemp) + (go end_label) + label20 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ztemp + (+ ztemp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%)) + (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%)))))) + (setf zdotc ztemp) + end_label + (return (values zdotc 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::zdotc fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zdotu BLAS} +\pagehead{zdotu}{zdotu} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun zdotu (n zx incx zy incy) + (declare (type (array (complex double-float) (*)) zy zx) + (type fixnum incy incx n)) + (f2cl-lib:with-multi-array-data + ((zx (complex double-float) zx-%data% zx-%offset%) + (zy (complex double-float) zy-%data% zy-%offset%)) + (prog ((i 0) (ix 0) (iy 0) (ztemp #C(0.0 0.0)) (zdotu #C(0.0 0.0))) + (declare (type (complex double-float) zdotu ztemp) + (type fixnum iy ix i)) + (setf ztemp (complex 0.0 0.0)) + (setf zdotu (complex 0.0 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 ztemp + (+ ztemp + (* (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%) + (f2cl-lib:fref zy-%data% (iy) ((1 *)) zy-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (setf zdotu ztemp) + (go end_label) + label20 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ztemp + (+ ztemp + (* (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%) + (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%)))))) + (setf zdotu ztemp) + end_label + (return (values zdotu 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::zdotu fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zdscal BLAS} +\pagehead{zdscal}{zdscal} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun zdscal (n da zx incx) + (declare (type (array (complex double-float) (*)) zx) + (type (double-float) da) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((zx (complex double-float) zx-%data% zx-%offset%)) + (prog ((i 0) (ix 0)) + (declare (type fixnum ix i)) + (if (or (<= n 0) (<= incx 0)) (go end_label)) + (if (= incx 1) (go label20)) + (setf ix 1) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%) + (* (coerce (complex da 0.0) '(complex doublefloat)) + (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%))) + (setf ix (f2cl-lib:int-add ix incx)))) + (go end_label) + label20 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%) + (* (coerce (complex da 0.0) '(complex double-float)) + (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%))))) + end_label + (return (values 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::zdscal + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum (double-float) + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zgbmv BLAS} +\pagehead{zgbmv}{zgbmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zgbmv (trans m n kl ku alpha a lda x incx beta y incy) + (declare (type (array (complex double-float) (*)) y x a) + (type (complex 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 (complex double-float) a-%data% a-%offset%) + (x (complex double-float) x-%data% x-%offset%) + (y (complex double-float) y-%data% y-%offset%)) + (prog ((noconj nil) (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 #C(0.0 0.0))) + (declare (type (member t nil) noconj) + (type fixnum i info ix iy j jx jy k kup1 kx ky + lenx leny) + (type (complex 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 "ZGBMV " info) + (go end_label))) + (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one))) + (go end_label)) + (setf noconj (lsame trans "T")) + (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)) + (cond + (noconj + (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%))))))) + (t + (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:dconjg + (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)) + (cond + (noconj + (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))))) + (t + (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:dconjg + (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::zgbmv fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum fixnum + fixnum fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum + ((complex double-float)) + (array (complex 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{zgemm BLAS} +\pagehead{zgemm}{zgemm} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zgemm (transa transb m n k alpha a lda b ldb$ beta c ldc) + (declare (type (array (complex double-float) (*)) c b a) + (type (complex 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 (complex double-float) a-%data% a-%offset%) + (b (complex double-float) b-%data% b-%offset%) + (c (complex double-float) c-%data% c-%offset%)) + (prog ((temp #C(0.0 0.0)) (i 0) (info 0) (j 0) (l 0) (ncola 0) (nrowa 0) + (nrowb 0) (conja nil) (conjb nil) (nota nil) (notb nil)) + (declare (type (complex double-float) temp) + (type fixnum i info j l ncola nrowa nrowb) + (type (member t nil) conja conjb nota notb)) + (setf nota (lsame transa "N")) + (setf notb (lsame transb "N")) + (setf conja (lsame transa "C")) + (setf conjb (lsame transb "C")) + (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 conja) (not (lsame transa "T"))) + (setf info 1)) + ((and (not notb) (not conjb) (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 "ZGEMM " 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%))))))))))))) + (conja + (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:dconjg + (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 + (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%))))))))))))) + (nota + (cond + (conjb + (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:dconjg + (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 + (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%))))))))))))))) + (conja + (cond + (conjb + (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:dconjg + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:dconjg + (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%))))))))))) + (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:dconjg + (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%))))))))))))) + (t + (cond + (conjb + (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:dconjg + (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%))))))))))) + (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::zgemm 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 + ((complex double-float)) + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum + ((complex double-float)) + (array (complex 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{zgemv BLAS} +\pagehead{zgemv}{zgemv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zgemv (trans m n alpha a lda x incx beta y incy) + (declare (type (array (complex double-float) (*)) y x a) + (type (complex 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 (complex double-float) a-%data% a-%offset%) + (x (complex double-float) x-%data% x-%offset%) + (y (complex double-float) y-%data% y-%offset%)) + (prog ((noconj nil) (i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) + (kx 0) (ky 0) (lenx 0) (leny 0) (temp #C(0.0 0.0))) + (declare (type (member t nil) noconj) + (type fixnum i info ix iy j jx jy kx ky lenx + leny) + (type (complex 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 "ZGEMV " info) + (go end_label))) + (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one))) + (go end_label)) + (setf noconj (lsame trans "T")) + (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) + (cond + (noconj + (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%))))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (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) + (cond + (noconj + (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))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (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::zgemv fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum + ((complex double-float)) + (array (complex 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{zgerc BLAS} +\pagehead{zgerc}{zgerc} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun zgerc (m n alpha x incx y incy a lda) + (declare (type (array (complex double-float) (*)) a y x) + (type (complex double-float) alpha) + (type fixnum lda incy incx n m)) + (f2cl-lib:with-multi-array-data + ((x (complex double-float) x-%data% x-%offset%) + (y (complex double-float) y-%data% y-%offset%) + (a (complex double-float) a-%data% a-%offset%)) + (prog ((i 0) (info 0) (ix 0) (j 0) (jy 0) (kx 0) (temp #C(0.0 0.0))) + (declare (type fixnum i info ix j jy kx) + (type (complex 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 "ZGERC " 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:dconjg + (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:dconjg + (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::zgerc fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zgeru BLAS} +\pagehead{zgeru}{zgeru} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun zgeru (m n alpha x incx y incy a lda) + (declare (type (array (complex double-float) (*)) a y x) + (type (complex double-float) alpha) + (type fixnum lda incy incx n m)) + (f2cl-lib:with-multi-array-data + ((x (complex double-float) x-%data% x-%offset%) + (y (complex double-float) y-%data% y-%offset%) + (a (complex double-float) a-%data% a-%offset%)) + (prog ((i 0) (info 0) (ix 0) (j 0) (jy 0) (kx 0) (temp #C(0.0 0.0))) + (declare (type fixnum i info ix j jy kx) + (type (complex 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 "ZGERU " 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::zgeru fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zhbmv BLAS} +\pagehead{zhbmv}{zhbmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zhbmv (uplo n k alpha a lda x incx beta y incy) + (declare (type (array (complex double-float) (*)) y x a) + (type (complex double-float) beta alpha) + (type fixnum incy incx lda k n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (x (complex double-float) x-%data% x-%offset%) + (y (complex double-float) y-%data% y-%offset%)) + (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (kplus1 0) (kx 0) + (ky 0) (l 0) (temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0))) + (declare (type fixnum i info ix iy j jx jy kplus1 kx ky l) + (type (complex double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((< k 0) + (setf info 3)) + ((< lda (f2cl-lib:int-add k 1)) + (setf info 6)) + ((= incx 0) + (setf info 8)) + ((= incy 0) + (setf info 11))) + (cond + ((/= info 0) + (xerbla "ZHBMV " info) + (go end_label))) + (if (or (= n 0) (and (= alpha zero) (= beta one))) (go end_label)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incy))))) + (cond + ((/= beta one) + (cond + ((= incy 1) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) 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 n) 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 n) 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 n) 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 uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)) + (* alpha temp2)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf ix kx) + (setf iy ky) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l 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 iy (f2cl-lib:int-add iy incy)))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (cond + ((> j k) + (setf kx (f2cl-lib:int-add kx incx)) + (setf ky (f2cl-lib:int-add ky incy))))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)))) + (setf l (f2cl-lib:int-sub 1 j)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* alpha temp2)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)))) + (setf l (f2cl-lib:int-sub 1 j)) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)) + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (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::zhbmv fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum + ((complex double-float)) + (array (complex 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{zhemm BLAS} +\pagehead{zhemm}{zhemm} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zhemm (side uplo m n alpha a lda b ldb$ beta c ldc) + (declare (type (array (complex double-float) (*)) c b a) + (type (complex double-float) beta alpha) + (type fixnum ldc ldb$ lda n m) + (type (simple-array character (*)) uplo side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (uplo character uplo-%data% uplo-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (b (complex double-float) b-%data% b-%offset%) + (c (complex double-float) c-%data% c-%offset%)) + (prog ((temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0)) (i 0) (info 0) (j 0) (k 0) + (nrowa 0) (upper nil)) + (declare (type (complex double-float) temp1 temp2) + (type fixnum i info j k nrowa) + (type (member t nil) upper)) + (cond + ((lsame side "L") + (setf nrowa m)) + (t + (setf nrowa n))) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not (lsame side "L")) (not (lsame side "R"))) + (setf info 1)) + ((and (not upper) (not (lsame uplo "L"))) + (setf info 2)) + ((< m 0) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 7)) + ((< ldb$ (max (the fixnum 1) (the fixnum m))) + (setf info 9)) + ((< ldc (max (the fixnum 1) (the fixnum m))) + (setf info 12))) + (cond + ((/= info 0) + (xerbla "ZHEMM " info) + (go end_label))) + (if (or (= m 0) (= n 0) (and (= alpha zero) (= 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 + ((lsame side "L") + (cond + (upper + (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 temp1 + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 zero) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add i + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%))))))) + (cond + ((= beta zero) + (setf + (f2cl-lib:fref c-%data% (i j) ((1 ldc) (1 *)) + c-%offset%) + (+ + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) + a-%offset%)) + 'double-float)) + (* alpha temp2)))) + (t + (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%)) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)) + + (* alpha temp2)))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i m (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 zero) + (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) + (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%))))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)) + (* alpha temp2)))) + (t + (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%)) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)) + (* alpha temp2)))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float))) + (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%) + (* temp1 + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (t + (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%)) + (* temp1 + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + (upper + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%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%) + (* temp1 + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))) + (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + (upper + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%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%) + (* temp1 + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))))) + end_label + (return (values 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::zhemm fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + (simple-array character (1)) + fixnum fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zhemv BLAS} +\pagehead{zhemv}{zhemv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zhemv (uplo n alpha a lda x incx beta y incy) + (declare (type (array (complex double-float) (*)) y x a) + (type (complex double-float) beta alpha) + (type fixnum incy incx lda n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (x (complex double-float) x-%data% x-%offset%) + (y (complex 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) + (temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0))) + (declare (type fixnum i info ix iy j jx jy kx ky) + (type (complex double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info 5)) + ((= incx 0) + (setf info 7)) + ((= incy 0) + (setf info 10))) + (cond + ((/= info 0) + (xerbla "ZHEMV " info) + (go end_label))) + (if (or (= n 0) (and (= alpha zero) (= beta one))) (go end_label)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incy))))) + (cond + ((/= beta one) + (cond + ((= incy 1) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) 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 n) 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 n) 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 n) 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 uplo "U") + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (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% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)) + (* alpha temp2)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf ix kx) + (setf iy ky) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (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 iy (f2cl-lib:int-add iy incy)))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (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% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* alpha temp2)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)))) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)) + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)))))))) + 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::zhemv fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zher2k BLAS} +\pagehead{zher2k}{zher2k} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0) (zero (complex 0.0 0.0))) + (declare (type (double-float 1.0 1.0) one) (type (complex double-float) zero)) + (defun zher2k (uplo trans n k alpha a lda b ldb$ beta c ldc) + (declare (type (double-float) beta) + (type (array (complex double-float) (*)) c b a) + (type (complex double-float) alpha) + (type fixnum ldc ldb$ lda k n) + (type (simple-array character (*)) trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (b (complex double-float) b-%data% b-%offset%) + (c (complex double-float) c-%data% c-%offset%)) + (prog ((temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0)) (i 0) (info 0) (j 0) (l 0) + (nrowa 0) (upper nil)) + (declare (type (complex double-float) temp1 temp2) + (type fixnum i info j l nrowa) + (type (member t nil) upper)) + (cond + ((lsame trans "N") + (setf nrowa n)) + (t + (setf nrowa k))) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not upper) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) (not (lsame trans "C"))) + (setf info 2)) + ((< n 0) + (setf info 3)) + ((< k 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 7)) + ((< ldb$ + (max (the fixnum 1) (the fixnum nrowa))) + (setf info 9)) + ((< ldc (max (the fixnum 1) (the fixnum n))) + (setf info 12))) + (cond + ((/= info 0) + (xerbla "ZHER2K" info) + (go end_label))) + (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) + (go end_label)) + (cond + ((= alpha zero) + (cond + (upper + (cond + ((= beta (coerce (realpart zero) 'double-float)) + (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 j) 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 + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + 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%))))) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float)) + '(complex double-float)))))))) + (t + (cond + ((= beta (coerce (realpart zero) 'double-float)) + (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 n) 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 + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float)) + '(complex double-float))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) 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 + ((lsame trans "N") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta (coerce (realpart zero) 'double-float)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) 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 + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + 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%))))) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float) + '(complex double-float))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) + (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + '(complex double-float))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + 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%) + (* + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%) + temp1) + (* + (f2cl-lib:fref b-%data% + (i l) + ((1 ldb$) (1 *)) + b-%offset%) + temp2))))) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%) + temp1) + (* + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%) + temp2))) 'double-float)) + '(complex double-float)))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta (coerce (realpart zero) 'double-float)) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) 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%))))) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%))' double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float) + '(complex double-float))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) + (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + '(complex double-float))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) 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%) + (* + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%) + temp1) + (* + (f2cl-lib:fref b-%data% + (i l) + ((1 ldb$) (1 *)) + b-%offset%) + temp2))))) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%) + temp1) + (* + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%) + temp2))) 'double-float)) + '(complex double-float)))))))))))) + (t + (cond + (upper + (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 j) nil) + (tagbody + (setf temp1 zero) + (setf temp2 zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp1 + (+ temp1 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref b-%data% + (l j) + ((1 ldb$) (1 *)) + b-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref b-%data% + (l i) + ((1 ldb$) (1 *)) + b-%offset%)) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= i j) + (cond + ((= beta (coerce (realpart zero) 'double-float)) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (coerce (realpart + (+ (* alpha temp1) + (* (f2cl-lib:dconjg alpha) temp2))) + 'double-float) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (+ + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) + 'double-float)) + (coerce (realpart + (+ (* alpha temp1) + (* (f2cl-lib:dconjg alpha) temp2))) + 'double-float)) + '(complex double-float)))))) + (t + (cond + ((= beta (coerce (realpart zero) 'double-float)) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp1) + (* (f2cl-lib:dconjg alpha) temp2)))) + (t + (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%)) + (* alpha temp1) + (* (f2cl-lib:dconjg alpha) temp2)))))))))))) + (t + (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 n) nil) + (tagbody + (setf temp1 zero) + (setf temp2 zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp1 + (+ temp1 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref b-%data% + (l j) + ((1 ldb$) (1 *)) + b-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref b-%data% + (l i) + ((1 ldb$) (1 *)) + b-%offset%)) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= i j) + (cond + ((= beta (coerce (realpart zero) 'double-float)) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (coerce (realpart + (+ (* alpha temp1) + (* (f2cl-lib:dconjg alpha) temp2))) + 'double-float) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (+ + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) + 'double-float)) + (coerce (realpart + (+ (* alpha temp1) + (* (f2cl-lib:dconjg alpha) temp2))) + 'double-float)) + '(complex double-float)))))) + (t + (cond + ((= beta (coerce (realpart zero) 'double-float)) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp1) + (* (f2cl-lib:dconjg alpha) temp2)))) + (t + (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%)) + (* alpha temp1) + (* (f2cl-lib:dconjg alpha) temp2))))))))))))))) + end_label + (return (values 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::zher2k + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + (simple-array character (1)) + fixnum fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum (double-float) + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zher2 BLAS} +\pagehead{zher2}{zher2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun zher2 (uplo n alpha x incx y incy a lda) + (declare (type (array (complex double-float) (*)) a y x) + (type (complex double-float) alpha) + (type fixnum lda incy incx n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (x (complex double-float) x-%data% x-%offset%) + (y (complex double-float) y-%data% y-%offset%) + (a (complex double-float) a-%data% a-%offset%)) + (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (kx 0) (ky 0) + (temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0))) + (declare (type fixnum i info ix iy j jx jy kx ky) + (type (complex double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (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 n))) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "ZHER2 " info) + (go end_label))) + (if (or (= n 0) (= alpha zero)) (go end_label)) + (cond + ((or (/= incx 1) (/= incy 1)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incy))))) + (setf jx kx) + (setf jy ky))) + (cond + ((lsame uplo "U") + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) + (/= (f2cl-lib:fref y (j) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + 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%) + temp1) + (* + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + temp2))))) + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%) + temp2))) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + '(complex double-float)))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf ix kx) + (setf iy ky) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + 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%) + temp1) + (* + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + temp2))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%) + temp2))) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + '(complex double-float))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) + (/= (f2cl-lib:fref y (j) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%) + temp2))) 'double-float)) + '(complex double-float))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) 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%) + temp1) + (* + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + temp2)))))) + (t + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + '(complex double-float)))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%) + temp2))) 'double-float)) + '(complex double-float))) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)) + (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%) + temp1) + (* + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + temp2)))))) + (t + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + '(complex double-float))))) + (setf jx (f2cl-lib:int-add jx 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::zher2 fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zherk BLAS} +\pagehead{zherk}{zherk} +%\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 zherk (uplo trans n k alpha a lda beta c ldc) + (declare (type (array (complex double-float) (*)) c a) + (type (double-float) beta alpha) + (type fixnum ldc lda k n) + (type (simple-array character (*)) trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (c (complex double-float) c-%data% c-%offset%)) + (prog ((temp #C(0.0 0.0)) (rtemp 0.0) (i 0) (info 0) (j 0) (l 0) + (nrowa 0) (upper nil)) + (declare (type (complex double-float) temp) + (type (double-float) rtemp) + (type fixnum i info j l nrowa) + (type (member t nil) upper)) + (cond + ((lsame trans "N") + (setf nrowa n)) + (t + (setf nrowa k))) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not upper) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) (not (lsame trans "C"))) + (setf info 2)) + ((< n 0) + (setf info 3)) + ((< k 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 7)) + ((< ldc (max (the fixnum 1) (the fixnum n))) + (setf info 10))) + (cond + ((/= info 0) + (xerbla "ZHERK " info) + (go end_label))) + (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) + (go end_label)) + (cond + ((= alpha zero) + (cond + (upper + (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 j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce zero '(complex double-float)))))))) + (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 + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + 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%))))) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float)) + '(complex double-float)))))))) + (t + (cond + ((= beta zero) + (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 n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce zero '(complex double-float)))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float)) + '(complex double-float))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) 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 + ((lsame trans "N") + (cond + (upper + (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 j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce zero '(complex double-float)))))) + ((/= beta one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + 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%))))) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float) + '(complex double-float))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) + (coerce (complex zero) '(complex double-float))) + (setf temp + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + '(complex double-float))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + 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%)))))) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float) + (coerce (realpart + (* temp + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%))) + 'double-float)) + '(complex double-float)))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce zero '(complex double-float)))))) + ((/= beta one) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float)) + '(complex double-float))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) 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%)))))) + (t + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float) + '(complex double-float))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) + (coerce (complex zero) '(complex double-float))) + (setf temp + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + '(complex double-float))) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float) + (coerce (realpart + (* temp + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + 'double-float)) + '(complex double-float))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) 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 + (cond + (upper + (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 + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf temp (coerce zero '(complex double-float))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%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%)))))))) + (setf rtemp zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf rtemp + (coerce + (realpart + (+ rtemp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))) + 'double-float)))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce (* alpha rtemp) '(complex double-float)))) + (t + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (+ (* alpha rtemp) + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) + 'double-float))) + '(complex double-float)))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf rtemp zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf rtemp + (coerce + (realpart + (+ rtemp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))) + 'double-float)))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce (* alpha rtemp) '(complex double-float)))) + (t + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (+ (* alpha rtemp) + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) + 'double-float))) + '(complex double-float))))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp (coerce zero '(complex double-float))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%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)))))) + +(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::zherk fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + (simple-array character (1)) + fixnum fixnum + (double-float) (array (complex double-float) (*)) + fixnum (double-float) + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zher BLAS} +\pagehead{zher}{zher} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun zher (uplo n alpha x incx a lda) + (declare (type (array (complex double-float) (*)) a x) + (type (double-float) alpha) + (type fixnum lda incx n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (x (complex double-float) x-%data% x-%offset%) + (a (complex double-float) a-%data% a-%offset%)) + (prog ((i 0) (info 0) (ix 0) (j 0) (jx 0) (kx 0) (temp #C(0.0 0.0))) + (declare (type fixnum i info ix j jx kx) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 5)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info 7))) + (cond + ((/= info 0) + (xerbla "ZHER " info) + (go end_label))) + (if (or (= n 0) (= alpha (coerce (realpart zero) 'double-float))) + (go end_label)) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + 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 (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + (coerce (realpart + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + temp)) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + '(complex double-float)))))))) + (t + (setf jx kx) + (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 + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf ix kx) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + 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 (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + (coerce (realpart + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + temp)) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + '(complex double-float))))) + (setf jx (f2cl-lib:int-add jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + (coerce (realpart + (* temp + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) 'double-float)) + '(complex double-float))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) 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)))))) + (t + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + '(complex double-float)))))))) + (t + (setf jx kx) + (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 + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + (coerce (realpart + (* temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) 'double-float)) + '(complex double-float))) + (setf ix jx) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (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)))))) + (t + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + '(complex double-float))))) + (setf jx (f2cl-lib:int-add jx incx)))))))) + 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::zher fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum (double-float) + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zhpmv BLAS} +\pagehead{zhpmv}{zhpmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zhpmv (uplo n alpha ap x incx beta y incy) + (declare (type (array (complex double-float) (*)) y x ap) + (type (complex double-float) beta alpha) + (type fixnum incy incx n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (ap (complex double-float) ap-%data% ap-%offset%) + (x (complex double-float) x-%data% x-%offset%) + (y (complex double-float) y-%data% y-%offset%)) + (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (k 0) (kk 0) + (kx 0) (ky 0) (temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0))) + (declare (type fixnum i info ix iy j jx jy k kk kx ky) + (type (complex double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 6)) + ((= incy 0) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "ZHPMV " info) + (go end_label))) + (if (or (= n 0) (and (= alpha zero) (= beta one))) (go end_label)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incy))))) + (cond + ((/= beta one) + (cond + ((= incy 1) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) 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 n) 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 n) 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 n) 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 kk 1) + (cond + ((lsame uplo "U") + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf k kk) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float)) + (* alpha temp2))) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf ix kx) + (setf iy ky) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub 2))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float)) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float)))) + (setf k (f2cl-lib:int-add kk 1)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* alpha temp2))) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float)))) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) + (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub j))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)) + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1))))))))) + 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::zhpmv fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum + ((complex double-float)) + (array (complex double-float) (*)) + (array (complex double-float) (*)) + fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zhpr2 BLAS} +\pagehead{zhpr2}{zhpr2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun zhpr2 (uplo n alpha x incx y incy ap) + (declare (type (array (complex double-float) (*)) ap y x) + (type (complex double-float) alpha) + (type fixnum incy incx n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (x (complex double-float) x-%data% x-%offset%) + (y (complex double-float) y-%data% y-%offset%) + (ap (complex double-float) ap-%data% ap-%offset%)) + (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (k 0) (kk 0) + (kx 0) (ky 0) (temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0))) + (declare (type fixnum i info ix iy j jx jy k kk kx ky) + (type (complex double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 5)) + ((= incy 0) + (setf info 7))) + (cond + ((/= info 0) + (xerbla "ZHPR2 " info) + (go end_label))) + (if (or (= n 0) (= alpha zero)) (go end_label)) + (cond + ((or (/= incx 1) (/= incy 1)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incy))))) + (setf jx kx) + (setf jy ky))) + (setf kk 1) + (cond + ((lsame uplo "U") + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) + (/= (f2cl-lib:fref y (j) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf k kk) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + temp2))) + (setf k (f2cl-lib:int-add k 1)))) + (setf (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%) + temp2))) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float) + '(complex double-float))))) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf ix kx) + (setf iy ky) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub 2))) + nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + temp2))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (setf (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%) + temp2))) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float) + '(complex double-float))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) + (/= (f2cl-lib:fref y (j) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%) + temp2))) 'double-float)) + '(complex double-float))) + (setf k (f2cl-lib:int-add kk 1)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + temp2))) + (setf k (f2cl-lib:int-add k 1))))) + (t + (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float) + '(complex double-float))))) + (setf kk + (f2cl-lib:int-add + (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) + 1))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%) + temp2))) 'double-float)) + '(complex double-float))) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) + (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub j))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)) + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + temp2)))))) + (t + (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float) + '(complex double-float))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (setf kk + (f2cl-lib:int-add + (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) + 1)))))))) + end_label + (return (values 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::zhpr2 fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*))) + :return-values '(nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zhpr BLAS} +\pagehead{zhpr}{zhpr} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun zhpr (uplo n alpha x incx ap) + (declare (type (array (complex double-float) (*)) ap x) + (type (double-float) alpha) + (type fixnum incx n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (x (complex double-float) x-%data% x-%offset%) + (ap (complex double-float) ap-%data% ap-%offset%)) + (prog ((i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0) (kk 0) (kx 0) + (temp #C(0.0 0.0))) + (declare (type fixnum i info ix j jx k kk kx) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 5))) + (cond + ((/= info 0) + (xerbla "ZHPR " info) + (go end_label))) + (if (or (= n 0) (= alpha (coerce (realpart zero) 'double-float))) + (go end_label)) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (setf kk 1) + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf k kk) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp))) + (setf k (f2cl-lib:int-add k 1)))) + (setf (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float) + (coerce (realpart + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + temp)) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float) + '(complex double-float))))) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (setf jx kx) + (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 + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf ix kx) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub 2))) + nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp))) + (setf ix (f2cl-lib:int-add ix incx)))) + (setf (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float) + (coerce (realpart + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + temp)) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float) + '(complex double-float))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float) + (coerce (realpart + (* temp + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) 'double-float)) + '(complex double-float))) + (setf k (f2cl-lib:int-add kk 1)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp))) + (setf k (f2cl-lib:int-add k 1))))) + (t + (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float) + '(complex double-float))))) + (setf kk + (f2cl-lib:int-add + (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) + 1))))) + (t + (setf jx kx) + (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 + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float) + (coerce (realpart + (* temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) 'double-float)) + '(complex double-float))) + (setf ix jx) + (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) + (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub j))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp)))))) + (t + (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float) + '(complex double-float))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk + (f2cl-lib:int-add + (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) + 1)))))))) + end_label + (return (values 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::zhpr fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum (double-float) + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*))) + :return-values '(nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlange LAPACK} +\pagehead{zlange}{zlange} +%\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 zlange (norm m n a lda work) + (declare (type (array double-float (*)) work) + (type (array (complex double-float) (*)) a) + (type fixnum lda n m) + (type (simple-array character (*)) norm)) + (f2cl-lib:with-multi-array-data + ((norm character norm-%data% norm-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (work double-float work-%data% work-%offset%)) + (prog ((scale 0.0) (sum 0.0) (value 0.0) (i 0) (j 0) (zlange 0.0)) + (declare (type fixnum i j) + (type (double-float) scale sum value zlange)) + (cond + ((= (min (the fixnum m) (the fixnum n)) 0) + (setf value zero)) + ((lsame norm "M") + (setf value zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf value + (max value + (abs + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%))))))))) + ((or (lsame norm "O") (f2cl-lib:fstring-= norm "1")) + (setf value zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf sum zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf sum + (+ sum + (abs + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf value (max value sum))))) + ((lsame norm "I") + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) + zero))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref work-%data% (i) ((1 *)) work-%offset%) + (+ + (f2cl-lib:fref work-%data% + (i) + ((1 *)) + work-%offset%) + (abs + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))))) + (setf value zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf value + (max value + (f2cl-lib:fref work-%data% + (i) + ((1 *)) + work-%offset%)))))) + ((or (lsame norm "F") (lsame norm "E")) + (setf scale zero) + (setf sum one) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (multiple-value-bind (var-0 var-1 var-2 var-3 var-4) + (zlassq m + (f2cl-lib:array-slice a + (complex double-float) + (1 j) + ((1 lda) (1 *))) + 1 scale sum) + (declare (ignore var-0 var-1 var-2)) + (setf scale var-3) + (setf sum var-4)))) + (setf value (* scale (f2cl-lib:fsqrt sum))))) + (setf zlange value) + (return (values zlange nil nil nil nil nil nil)))))) + +(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::zlange + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + fixnum fixnum + (array (complex double-float) (*)) + fixnum (array double-float (*))) + :return-values '(nil nil nil nil nil nil) + :calls '(fortran-to-lisp::lsame fortran-to-lisp::zlassq)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zlassq LAPACK} +\pagehead{zlassq}{zlassq} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun zlassq (n x incx scale sumsq) + (declare (type (double-float) sumsq scale) + (type (array (complex double-float) (*)) x) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((x (complex double-float) x-%data% x-%offset%)) + (prog ((temp1 0.0) (ix 0)) + (declare (type (double-float) temp1) (type fixnum ix)) + (cond + ((> n 0) + (f2cl-lib:fdo (ix 1 (f2cl-lib:int-add ix incx)) + ((> ix + (f2cl-lib:int-add 1 + (f2cl-lib:int-mul + (f2cl-lib:int-add n + (f2cl-lib:int-sub 1)) + incx))) + nil) + (tagbody + (cond + ((/= (coerce (realpart (f2cl-lib:fref x (ix) ((1 *)))) 'double-float) zero) + (setf temp1 + (abs + (coerce (realpart + (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%)) 'double-float))) + (cond + ((< scale temp1) + (setf sumsq (+ 1 (* sumsq (expt (/ scale temp1) 2)))) + (setf scale temp1)) + (t + (setf sumsq (+ sumsq (expt (/ temp1 scale) 2))))))) + (cond + ((/= (f2cl-lib:dimag (f2cl-lib:fref x (ix) ((1 *)))) zero) + (setf temp1 + (abs + (f2cl-lib:dimag + (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%)))) + (cond + ((< scale temp1) + (setf sumsq (+ 1 (* sumsq (expt (/ scale temp1) 2)))) + (setf scale temp1)) + (t + (setf sumsq (+ sumsq (expt (/ temp1 scale) 2))))))))))) + (return (values nil nil nil scale sumsq)))))) + +(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::zlassq + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum + (array (complex double-float) (*)) + fixnum (double-float) + (double-float)) + :return-values '(nil nil nil fortran-to-lisp::scale + fortran-to-lisp::sumsq) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zrotg BLAS} +\pagehead{zrotg}{zrotg} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + + +(Complex Double-Float). Computes plane rotation. +Arguments are: +\begin{itemize} +\item da - (complex double-float) +\item db - (complex double-float) +\item c - double-float +\item s - (complex double-float) +\end{itemize} +Returns multiple values where: +\begin{itemize} +\item 1 da - ca +\item 2 db - nil +\item 3 c - c +\item 4 s - s +\end{itemize} + +<>= +(defun zrotg (ca cb c s) + (declare (type (double-float) c) (type (complex double-float) s cb ca)) + (prog ((alpha #C(0.0 0.0)) (norm 0.0) (scale 0.0)) + (declare (type (double-float) scale norm) + (type (complex double-float) alpha)) + (if (/= (f2cl-lib:cdabs ca) 0.0) (go label10)) + (setf c 0.0) + (setf s (complex 1.0 0.0)) + (setf ca cb) + (go label20) + label10 + (setf scale + (coerce (+ (f2cl-lib:cdabs ca) (f2cl-lib:cdabs cb)) 'double-float)) + (setf norm + (* scale + (f2cl-lib:dsqrt + (+ (expt (f2cl-lib:cdabs (/ ca + (coerce (complex scale 0.0) '(complex double-float)))) 2) + (expt (f2cl-lib:cdabs (/ cb + (coerce (complex scale 0.0) '(complex double-float)))) + 2))))) + (setf alpha (/ ca (f2cl-lib:cdabs ca))) + (setf c (/ (f2cl-lib:cdabs ca) norm)) + (setf s (/ (* alpha (f2cl-lib:dconjg cb)) norm)) + (setf ca (* alpha norm)) + label20 + (return (values ca nil c s)))) + +(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::zrotg fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(((complex double-float)) + ((complex double-float)) (double-float) + ((complex double-float))) + :return-values '(fortran-to-lisp::ca nil fortran-to-lisp::c + fortran-to-lisp::s) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zscal BLAS} +\pagehead{zscal}{zscal} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun zscal (n za zx incx) + (declare (type (array (complex double-float) (*)) zx) + (type (complex double-float) za) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((zx (complex double-float) zx-%data% zx-%offset%)) + (prog ((i 0) (ix 0)) + (declare (type fixnum ix i)) + (if (or (<= n 0) (<= incx 0)) (go end_label)) + (if (= incx 1) (go label20)) + (setf ix 1) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%) + (* za (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%))) + (setf ix (f2cl-lib:int-add ix incx)))) + (go end_label) + label20 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%) + (* za (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%))))) + end_label + (return (values 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::zscal fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zswap BLAS} +\pagehead{zswap}{zswap} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun zswap (n zx incx zy incy) + (declare (type (array (complex double-float) (*)) zy zx) + (type fixnum incy incx n)) + (f2cl-lib:with-multi-array-data + ((zx (complex double-float) zx-%data% zx-%offset%) + (zy (complex double-float) zy-%data% zy-%offset%)) + (prog ((i 0) (ix 0) (iy 0) (ztemp #C(0.0 0.0))) + (declare (type (complex double-float) ztemp) + (type fixnum 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 ztemp (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%)) + (setf (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%) + (f2cl-lib:fref zy-%data% (iy) ((1 *)) zy-%offset%)) + (setf (f2cl-lib:fref zy-%data% (iy) ((1 *)) zy-%offset%) ztemp) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (go end_label) + label20 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ztemp (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%)) + (setf (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%) + (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%)) + (setf (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%) ztemp))) + 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::zswap fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '(fixnum + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil) + :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zsymm BLAS} +\pagehead{zsymm}{zsymm} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zsymm (side uplo m n alpha a lda b ldb$ beta c ldc) + (declare (type (array (complex double-float) (*)) c b a) + (type (complex double-float) beta alpha) + (type fixnum ldc ldb$ lda n m) + (type (simple-array character (*)) uplo side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (uplo character uplo-%data% uplo-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (b (complex double-float) b-%data% b-%offset%) + (c (complex double-float) c-%data% c-%offset%)) + (prog ((temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0)) (i 0) (info 0) (j 0) (k 0) + (nrowa 0) (upper nil)) + (declare (type (complex double-float) temp1 temp2) + (type fixnum i info j k nrowa) + (type (member t nil) upper)) + (cond + ((lsame side "L") + (setf nrowa m)) + (t + (setf nrowa n))) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not (lsame side "L")) (not (lsame side "R"))) + (setf info 1)) + ((and (not upper) (not (lsame uplo "L"))) + (setf info 2)) + ((< m 0) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 7)) + ((< ldb$ (max (the fixnum 1) (the fixnum m))) + (setf info 9)) + ((< ldc (max (the fixnum 1) (the fixnum m))) + (setf info 12))) + (cond + ((/= info 0) + (xerbla "ZSYMM " info) + (go end_label))) + (if (or (= m 0) (= n 0) (and (= alpha zero) (= 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 + ((lsame side "L") + (cond + (upper + (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 temp1 + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 zero) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add i + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* temp1 + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))) + (t + (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%)) + (* temp1 + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i m (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 zero) + (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) + (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* temp1 + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))) + (t + (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%)) + (* temp1 + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))) + (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%) + (* temp1 + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (t + (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%)) + (* temp1 + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + (upper + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%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%) + (* temp1 + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))) + (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + (upper + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%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%) + (* temp1 + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))))) + end_label + (return (values 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::zsymm fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + (simple-array character (1)) + fixnum fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zsyr2k BLAS} +\pagehead{zsyr2k}{zsyr2k} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zsyr2k (uplo trans n k alpha a lda b ldb$ beta c ldc) + (declare (type (array (complex double-float) (*)) c b a) + (type (complex double-float) beta alpha) + (type fixnum ldc ldb$ lda k n) + (type (simple-array character (*)) trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (b (complex double-float) b-%data% b-%offset%) + (c (complex double-float) c-%data% c-%offset%)) + (prog ((temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0)) (i 0) (info 0) (j 0) (l 0) + (nrowa 0) (upper nil)) + (declare (type (complex double-float) temp1 temp2) + (type fixnum i info j l nrowa) + (type (member t nil) upper)) + (cond + ((lsame trans "N") + (setf nrowa n)) + (t + (setf nrowa k))) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not upper) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) (not (lsame trans "T"))) + (setf info 2)) + ((< n 0) + (setf info 3)) + ((< k 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 7)) + ((< ldb$ + (max (the fixnum 1) (the fixnum nrowa))) + (setf info 9)) + ((< ldc (max (the fixnum 1) (the fixnum n))) + (setf info 12))) + (cond + ((/= info 0) + (xerbla "ZSYR2K" info) + (go end_label))) + (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) + (go end_label)) + (cond + ((= alpha zero) + (cond + (upper + (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 j) 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 j) 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%)))))))))) + (t + (cond + ((= beta zero) + (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 n) 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 j (f2cl-lib:int-add i 1)) + ((> i n) 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 + ((lsame trans "N") + (cond + (upper + (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 j) 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 j) 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 + ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) + (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) 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%) + (* + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%) + temp1) + (* + (f2cl-lib:fref b-%data% + (i l) + ((1 ldb$) (1 *)) + b-%offset%) + temp2)))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) 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 + ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) + (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) 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%) + (* + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%) + temp1) + (* + (f2cl-lib:fref b-%data% + (i l) + ((1 ldb$) (1 *)) + b-%offset%) + temp2)))))))))))))) + (t + (cond + (upper + (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 j) nil) + (tagbody + (setf temp1 zero) + (setf temp2 zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp1 + (+ temp1 + (* + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (l j) + ((1 ldb$) (1 *)) + b-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (l i) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp1) (* alpha temp2)))) + (t + (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%)) + (* alpha temp1) + (* alpha temp2)))))))))) + (t + (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 n) nil) + (tagbody + (setf temp1 zero) + (setf temp2 zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp1 + (+ temp1 + (* + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (l j) + ((1 ldb$) (1 *)) + b-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (l i) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp1) (* alpha temp2)))) + (t + (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%)) + (* alpha temp1) + (* alpha temp2))))))))))))) + end_label + (return (values 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::zsyr2k + fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + (simple-array character (1)) + fixnum fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zsyrk BLAS} +\pagehead{zsyrk}{zsyrk} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zsyrk (uplo trans n k alpha a lda beta c ldc) + (declare (type (array (complex double-float) (*)) c a) + (type (complex double-float) beta alpha) + (type fixnum ldc lda k n) + (type (simple-array character (*)) trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (c (complex double-float) c-%data% c-%offset%)) + (prog ((temp #C(0.0 0.0)) (i 0) (info 0) (j 0) (l 0) (nrowa 0) + (upper nil)) + (declare (type (complex double-float) temp) + (type fixnum i info j l nrowa) + (type (member t nil) upper)) + (cond + ((lsame trans "N") + (setf nrowa n)) + (t + (setf nrowa k))) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not upper) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) (not (lsame trans "T"))) + (setf info 2)) + ((< n 0) + (setf info 3)) + ((< k 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 7)) + ((< ldc (max (the fixnum 1) (the fixnum n))) + (setf info 10))) + (cond + ((/= info 0) + (xerbla "ZSYRK " info) + (go end_label))) + (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) + (go end_label)) + (cond + ((= alpha zero) + (cond + (upper + (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 j) 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 j) 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%)))))))))) + (t + (cond + ((= beta zero) + (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 n) 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 j (f2cl-lib:int-add i 1)) + ((> i n) 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 + ((lsame trans "N") + (cond + (upper + (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 j) 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 j) 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 a (j l) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) 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 + (cond + ((= beta zero) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) 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 a (j l) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) 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 + (cond + (upper + (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 j) 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 a-%data% + (l j) + ((1 lda) (1 *)) + a-%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 + (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 n) 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 a-%data% + (l j) + ((1 lda) (1 *)) + a-%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)))))) + +(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::zsyrk fortran-to-lisp::*f2cl-function-info*) + (fortran-to-lisp::make-f2cl-finfo + :arg-types '((simple-array character (1)) + (simple-array character (1)) + fixnum fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ztbmv BLAS} +\pagehead{ztbmv}{ztbmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun ztbmv (uplo trans diag n k a lda x incx) + (declare (type (array (complex double-float) (*)) x a) + (type fixnum incx lda k n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (x (complex double-float) x-%data% x-%offset%)) + (prog ((noconj nil) (nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) + (kplus1 0) (kx 0) (l 0) (temp #C(0.0 0.0))) + (declare (type (member t nil) noconj nounit) + (type fixnum i info ix j jx kplus1 kx l) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< k 0) + (setf info 5)) + ((< lda (f2cl-lib:int-add k 1)) + (setf info 7)) + ((= incx 0) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "ZTBMV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf noconj (lsame trans "T")) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%))))))))) + (t + (setf jx kx) + (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 + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (if (> j k) (setf kx (f2cl-lib:int-add kx incx)))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub 1 j)) + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%))))))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (setf l (f2cl-lib:int-sub 1 j)) + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf jx (f2cl-lib:int-sub jx incx)) + (if (>= (f2cl-lib:int-sub n j) k) + (setf kx (f2cl-lib:int-sub kx incx)))))))))) + (t + (cond + ((lsame uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub kplus1 j)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf kx (f2cl-lib:int-sub kx incx)) + (setf ix kx) + (setf l (f2cl-lib:int-sub kplus1 j)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub 1 j)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf kx (f2cl-lib:int-add kx incx)) + (setf ix kx) + (setf l (f2cl-lib:int-sub 1 j)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l 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 x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)))))))))) + 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::ztbmv 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)) + fixnum fixnum + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ztbsv BLAS} +\pagehead{ztbsv}{ztbsv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun ztbsv (uplo trans diag n k a lda x incx) + (declare (type (array (complex double-float) (*)) x a) + (type fixnum incx lda k n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (x (complex double-float) x-%data% x-%offset%)) + (prog ((noconj nil) (nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) + (kplus1 0) (kx 0) (l 0) (temp #C(0.0 0.0))) + (declare (type (member t nil) noconj nounit) + (type fixnum i info ix j jx kplus1 kx l) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< k 0) + (setf info 5)) + ((< lda (f2cl-lib:int-add k 1)) + (setf info 7)) + ((= incx 0) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "ZTBSV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf noconj (lsame trans "T")) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf l (f2cl-lib:int-sub kplus1 j)) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%))))))))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf kx (f2cl-lib:int-sub kx incx)) + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf ix kx) + (setf l (f2cl-lib:int-sub kplus1 j)) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))))) + (setf jx (f2cl-lib:int-sub jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf l (f2cl-lib:int-sub 1 j)) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%))))))))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf kx (f2cl-lib:int-add kx incx)) + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf ix kx) + (setf l (f2cl-lib:int-sub 1 j)) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))))) + (setf jx (f2cl-lib:int-add jx incx))))))))) + (t + (cond + ((lsame uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub kplus1 j)) + (cond + (noconj + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (setf l (f2cl-lib:int-sub kplus1 j)) + (cond + (noconj + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)) + (if (> j k) (setf kx (f2cl-lib:int-add kx incx)))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub 1 j)) + (cond + (noconj + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (setf l (f2cl-lib:int-sub 1 j)) + (cond + (noconj + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx)) + (if (>= (f2cl-lib:int-sub n j) k) + (setf kx (f2cl-lib:int-sub kx incx))))))))))) + 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::ztbsv 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)) + fixnum fixnum + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ztpmv BLAS} +\pagehead{ztpmv}{ztpmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun ztpmv (uplo trans diag n ap x incx) + (declare (type (array (complex double-float) (*)) x ap) + (type fixnum incx n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (ap (complex double-float) ap-%data% ap-%offset%) + (x (complex double-float) x-%data% x-%offset%)) + (prog ((noconj nil) (nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0) + (kk 0) (kx 0) (temp #C(0.0 0.0))) + (declare (type (member t nil) noconj nounit) + (type fixnum i info ix j jx k kk kx) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((= incx 0) + (setf info 7))) + (cond + ((/= info 0) + (xerbla "ZTPMV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf noconj (lsame trans "T")) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (setf kk 1) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k kk) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)))))) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (setf jx kx) + (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 + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub + 2))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k kk) + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-sub k 1)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk n) + j)) + ((1 *)) + ap-%offset%)))))) + (setf kk + (f2cl-lib:int-sub kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (k kk + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub + (f2cl-lib:int-add + n + (f2cl-lib:int-sub + (f2cl-lib:int-add + j + 1)))))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk n) + j)) + ((1 *)) + ap-%offset%)))))) + (setf jx (f2cl-lib:int-sub jx incx)) + (setf kk + (f2cl-lib:int-sub kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))))))) + (t + (cond + ((lsame uplo "U") + (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k (f2cl-lib:int-sub kk 1)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-sub k 1))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%))))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-sub k 1)))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp) + (setf kk (f2cl-lib:int-sub kk j))))) + (t + (setf jx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix jx) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (f2cl-lib:fdo (k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub + j) + 1)) + nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%))))) + (f2cl-lib:fdo (k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub + j) + 1)) + nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx)) + (setf kk (f2cl-lib:int-sub kk j))))))) + (t + (setf kk 1) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k (f2cl-lib:int-add kk 1)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%))))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix jx) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) + (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub + j))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%))))) + (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) + (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub + j))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1))))))))))) + 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::ztpmv 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)) + fixnum + (array (complex double-float) (*)) + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ztpsv BLAS} +\pagehead{ztpsv}{ztpsv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun ztpsv (uplo trans diag n ap x incx) + (declare (type (array (complex double-float) (*)) x ap) + (type fixnum incx n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (ap (complex double-float) ap-%data% ap-%offset%) + (x (complex double-float) x-%data% x-%offset%)) + (prog ((noconj nil) (nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0) + (kk 0) (kx 0) (temp #C(0.0 0.0))) + (declare (type (member t nil) noconj nounit) + (type fixnum i info ix j jx k kk kx) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((= incx 0) + (setf info 7))) + (cond + ((/= info 0) + (xerbla "ZTPSV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf noconj (lsame trans "T")) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k (f2cl-lib:int-sub kk 1)) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-sub k 1)))))) + (setf kk (f2cl-lib:int-sub kk j))))) + (t + (setf jx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix jx) + (f2cl-lib:fdo (k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub + j) + 1)) + nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))))))) + (setf jx (f2cl-lib:int-sub jx incx)) + (setf kk (f2cl-lib:int-sub kk j))))))) + (t + (setf kk 1) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k (f2cl-lib:int-add kk 1)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))))) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix jx) + (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) + (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub + j))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))))))) + (t + (cond + ((lsame uplo "U") + (setf kk 1) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k kk) + (cond + (noconj + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk + j) + 1)) + ((1 *)) + ap-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (cond + (noconj + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub + 2))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%))))) + (t + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub + 2))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk + j) + 1)) + ((1 *)) + ap-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k kk) + (cond + (noconj + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-sub k 1)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk n) + j)) + ((1 *)) + ap-%offset%))))) + (t + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-sub k 1)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk + n) + j)) + ((1 *)) + ap-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp) + (setf kk + (f2cl-lib:int-sub kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (cond + (noconj + (f2cl-lib:fdo (k kk + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub + (f2cl-lib:int-add + n + (f2cl-lib:int-sub + (f2cl-lib:int-add + j + 1)))))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk n) + j)) + ((1 *)) + ap-%offset%))))) + (t + (f2cl-lib:fdo (k kk + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub + (f2cl-lib:int-add + n + (f2cl-lib:int-sub + (f2cl-lib:int-add + j + 1)))))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk + n) + j)) + ((1 *)) + ap-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx)) + (setf kk + (f2cl-lib:int-sub kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1))))))))))) + 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::ztpsv 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)) + fixnum + (array (complex double-float) (*)) + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ztrmm BLAS} +\pagehead{ztrmm}{ztrmm} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun ztrmm (side uplo transa diag m n alpha a lda b ldb$) + (declare (type (array (complex double-float) (*)) b a) + (type (complex double-float) alpha) + (type fixnum ldb$ lda n m) + (type (simple-array character (*)) diag transa uplo side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (uplo character uplo-%data% uplo-%offset%) + (transa character transa-%data% transa-%offset%) + (diag character diag-%data% diag-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (b (complex double-float) b-%data% b-%offset%)) + (prog ((temp #C(0.0 0.0)) (i 0) (info 0) (j 0) (k 0) (nrowa 0) + (lside nil) (noconj nil) (nounit nil) (upper nil)) + (declare (type (complex double-float) temp) + (type fixnum i info j k nrowa) + (type (member t nil) lside noconj nounit upper)) + (setf lside (lsame side "L")) + (cond + (lside + (setf nrowa m)) + (t + (setf nrowa n))) + (setf noconj (lsame transa "T")) + (setf nounit (lsame diag "N")) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not lside) (not (lsame side "R"))) + (setf info 1)) + ((and (not upper) (not (lsame uplo "L"))) + (setf info 2)) + ((and (not (lsame transa "N")) + (not (lsame transa "T")) + (not (lsame transa "C"))) + (setf info 3)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 4)) + ((< m 0) + (setf info 5)) + ((< n 0) + (setf info 6)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 9)) + ((< ldb$ (max (the fixnum 1) (the fixnum m))) + (setf info 11))) + (cond + ((/= info 0) + (xerbla "ZTRMM " info) + (go end_label))) + (if (= n 0) (go end_label)) + (cond + ((= alpha 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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + zero))))) + (go end_label))) + (cond + (lside + (cond + ((lsame transa "N") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add k + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (+ + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + temp)))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (k m + (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + temp) + (if nounit + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add k 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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%))))))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i m + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add i + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add i + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))))) + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha temp))))))) + (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 + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) + (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) + (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))))) + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha temp))))))))))) + (t + (cond + ((lsame transa "N") + (cond + (upper + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp alpha) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (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%) + (* temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%))) + (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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp alpha) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (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%) + (* temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))) + (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) + (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%))) + (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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) + (cond + (noconj + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)))))) + (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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (setf temp alpha) + (cond + (nounit + (cond + (noconj + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))))))) + (cond + ((/= temp one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (t + (f2cl-lib:fdo (k n (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k 1) nil) + (tagbody + (f2cl-lib:fdo (j (f2cl-lib:int-add k 1) + (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) + (cond + (noconj + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)))))) + (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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (setf temp alpha) + (cond + (nounit + (cond + (noconj + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))))))) + (cond + ((/= temp one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))))))))))) + 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::ztrmm 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 fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum + (array (complex 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{ztrmv BLAS} +\pagehead{ztrmv}{ztrmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun ztrmv (uplo trans diag n a lda x incx) + (declare (type (array (complex double-float) (*)) x a) + (type fixnum incx lda n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (x (complex double-float) x-%data% x-%offset%)) + (prog ((noconj nil) (nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) + (kx 0) (temp #C(0.0 0.0))) + (declare (type (member t nil) noconj nounit) + (type fixnum i info ix j jx kx) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info 6)) + ((= incx 0) + (setf info 8))) + (cond + ((/= info 0) + (xerbla "ZTRMV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf noconj (lsame trans "T")) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))))))) + (t + (setf jx kx) + (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 + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf jx (f2cl-lib:int-add jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf jx (f2cl-lib:int-sub jx incx))))))))) + (t + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) 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%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (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 x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix jx) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) 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%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (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 x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix jx) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)))))))))) + end_label + (return (values 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::ztrmv 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)) + fixnum + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ztrsm BLAS} +\pagehead{ztrsm}{ztrsm} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun ztrsm (side uplo transa diag m n alpha a lda b ldb$) + (declare (type (array (complex double-float) (*)) b a) + (type (complex double-float) alpha) + (type fixnum ldb$ lda n m) + (type (simple-array character (*)) diag transa uplo side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (uplo character uplo-%data% uplo-%offset%) + (transa character transa-%data% transa-%offset%) + (diag character diag-%data% diag-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (b (complex double-float) b-%data% b-%offset%)) + (prog ((temp #C(0.0 0.0)) (i 0) (info 0) (j 0) (k 0) (nrowa 0) + (lside nil) (noconj nil) (nounit nil) (upper nil)) + (declare (type (complex double-float) temp) + (type fixnum i info j k nrowa) + (type (member t nil) lside noconj nounit upper)) + (setf lside (lsame side "L")) + (cond + (lside + (setf nrowa m)) + (t + (setf nrowa n))) + (setf noconj (lsame transa "T")) + (setf nounit (lsame diag "N")) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not lside) (not (lsame side "R"))) + (setf info 1)) + ((and (not upper) (not (lsame uplo "L"))) + (setf info 2)) + ((and (not (lsame transa "N")) + (not (lsame transa "T")) + (not (lsame transa "C"))) + (setf info 3)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 4)) + ((< m 0) + (setf info 5)) + ((< n 0) + (setf info 6)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 9)) + ((< ldb$ (max (the fixnum 1) (the fixnum m))) + (setf info 11))) + (cond + ((/= info 0) + (xerbla "ZTRSM " info) + (go end_label))) + (if (= n 0) (go end_label)) + (cond + ((= alpha 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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + zero))))) + (go end_label))) + (cond + (lside + (cond + ((lsame transa "N") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= alpha one) + (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%) + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (k m + (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) + (if nounit + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (/ + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add k + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (- + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%))))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= alpha one) + (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%) + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) + (if nounit + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (/ + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add k 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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%))))))))))))))) + (t + (cond + (upper + (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 + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (cond + (noconj + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add i + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add i + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + temp)))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i m + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (cond + (noconj + (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) + (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) + (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + temp)))))))))) + (t + (cond + ((lsame transa "N") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= alpha one) + (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%) + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) + (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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (cond + (nounit + (setf temp + (/ one + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))) + (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%) + (* temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (t + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= alpha one) + (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%) + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) + (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) + (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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (cond + (nounit + (setf temp + (/ one + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))) + (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%) + (* temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (k n (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k 1) nil) + (tagbody + (cond + (nounit + (cond + (noconj + (setf temp + (/ one + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp + (/ one + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) + (cond + (noconj + (setf temp + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%))) + (t + (setf temp + (coerce + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)) + '(complex double-float))))) + (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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (cond + ((/= alpha one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (t + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + (nounit + (cond + (noconj + (setf temp + (/ one + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp + (/ one + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (j (f2cl-lib:int-add k 1) + (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) + (cond + (noconj + (setf temp + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%))) + (t + (setf temp + (coerce + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)) + '(complex double-float))))) + (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 b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (cond + ((/= alpha one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))))))))))) + 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::ztrsm 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 fixnum + ((complex double-float)) + (array (complex double-float) (*)) + fixnum + (array (complex 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{ztrsv BLAS} +\pagehead{ztrsv}{ztrsv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun ztrsv (uplo trans diag n a lda x incx) + (declare (type (array (complex double-float) (*)) x a) + (type fixnum incx lda n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (x (complex double-float) x-%data% x-%offset%)) + (prog ((noconj nil) (nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) + (kx 0) (temp #C(0.0 0.0))) + (declare (type (member t nil) noconj nounit) + (type fixnum i info ix j jx kx) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info 6)) + ((= incx 0) + (setf info 8))) + (cond + ((/= info 0) + (xerbla "ZTRSV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf noconj (lsame trans "T")) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%))))))))))) + (t + (setf jx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix jx) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))))) + (setf jx (f2cl-lib:int-sub jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%))))))))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix jx) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))))) + (setf jx (f2cl-lib:int-add jx incx))))))))) + (t + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (cond + (noconj + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + 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%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf ix kx) + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (cond + (noconj + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + 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)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (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)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (cond + (noconj + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) 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%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf ix kx) + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (cond + (noconj + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) 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-sub ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (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-sub ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx)))))))))) + end_label + (return (values 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::ztrsv 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)) + fixnum + (array (complex double-float) (*)) + fixnum + (array (complex double-float) (*)) + fixnum) + :return-values '(nil nil nil nil nil nil nil nil) + :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Chunk collections} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +<<*>>= +<> +<> +<> +<> +<> +<> +<>= +<> + +<> +<> +<> + +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> + +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> + +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> + +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{Index} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\printindex +\end{document} + diff --git a/changelog b/changelog index 14860f1..bd649e7 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,5 @@ +20100323 tpd src/axiom-website/patches.html 20100323.01.tpd.patch +20100323 tpd books/bookvol10.5 first draft of numerics volume 20100316 tpd src/axiom-website/patches.html 2010316.01.tpd.patch 20100316 tpd books/bookvol10 add Elementary Functions branch cuts 20100311 tpd src/axiom-website/patches.html 2010311.02.tpd.patch diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index e9afd56..8cf1e91 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -2576,5 +2576,7 @@ src/axiom-website/style.css rewrite per Nate Daly
books/bookvol5.pamphlet add Nate Daly to credits
20100316.01.tpd.patch books/bookvol10 add Elementary Functions branch cuts
+20100323.01.tpd.patch +books/bookvol10.5 first draft of numerics volume