diff --git a/books/bookvol10.5.pamphlet b/books/bookvol10.5.pamphlet
index 2e20ffd..5fbcb2a 100644
--- a/books/bookvol10.5.pamphlet
+++ b/books/bookvol10.5.pamphlet
@@ -525,7 +525,7 @@ BlasLevelOne() : Exports == Implementation where
++ dcabs1(z) computes (+ (abs (realpart z)) (abs (imagpart z)))
++
++X t1:Complex DoubleFloat := complex(1.0,0)
- ++X dcabs(t1)
+ ++X dcabs1(t1)
dasum: (SI, DX, SI) -> DF
++ dasum(n,array,incx) computes the sum of n elements in array
@@ -743,7 +743,7 @@ the real part and whose cdr is the imaginary part. This fact is used
in this implementation.
This should really be a macro.
-\begin{verbatim}
+\begin{chunk}{dcabs1.f}
double precision function dcabs1(z)
C ORIGINAL:
c double complex z,zz
@@ -759,7 +759,26 @@ c NEW
\end{verbatim}
-\begin{chunk}{BLAS dcabs1}
+\begin{chunk}{dcabs1 example}
+ program dcabs1EX
+ double complex a,b,c,d
+ a=COMPLEX(2.1,2.1)
+ b=(3.1D2,4.1D3)
+ c=a+b
+ d=dcabs1(c)
+ write(6,100)a
+ 100 format(" a=(",f10.3,",",f10.3,")")
+ write(6,200)b
+ 200 format(" b=(",f10.3,",",f10.3,")")
+ write(6,300)c
+ 300 format(" a+b=(",f10.3,",",f10.3,")")
+ write(6,400)d
+ 400 format("dcabs1(c)=(",f10.3,",",f10.3,")")
+ stop
+ end
+\end{chunk}
+
+\begin{chunk}{BLAS 1 dcabs1}
(defun dcabs1 (z)
"Complex(DoubleFloat) z is a pair where (realpart . imaginarypart).
The result is a DoubleFloat (+ (abs (realpart z)) (abs (imagpart z)))"
@@ -769,6 +788,11 @@ c NEW
(the double-float (abs (the double-float (cdr z)))))))
\end{chunk}
+
+\begin{chunk}{BLAS 1 dcabs1 test}
+(dcabs1 '(312.100 . 4102.100))
+\end{chunk}
+
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{lsame BLAS}
%\pagehead{lsame}{lsame}
@@ -781,7 +805,7 @@ This has been replaced everywhere with common lisp's char-equal function
which compares characters ignoring case. The type
(simple-array character (*)) has been replaced everywhere which character.
-\begin{verbatim}
+\begin{chunk}{lsame.f}
LOGICAL FUNCTION LSAME( CA, CB )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -884,7 +908,7 @@ It is called if an input parameter has an invalid value.
This function has been rewritten everywhere to use the common lisp error
function.
-\begin{verbatim}
+\begin{chunk}{xerbla.f}
SUBROUTINE XERBLA( SRNAME, INFO )
*
* -- LAPACK auxiliary routine (preliminary version) --
@@ -1363,7 +1387,7 @@ NOTES:
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dasum.f}
double precision function dasum(n,dx,incx)
c
c takes the sum of the absolute values.
@@ -1408,7 +1432,7 @@ c
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 dasum}
(defun dasum (n dx incx)
@@ -1774,7 +1798,7 @@ RETURN VALUES
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{daxpy.f}
subroutine daxpy(n,da,dx,incx,dy,incy)
c
c constant times a vector plus a vector.
@@ -1824,7 +1848,7 @@ c
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 daxpy}
(defun daxpy (n da dx incx dy incy)
@@ -2158,7 +2182,7 @@ ARGUMENTS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dcopy.f}
subroutine dcopy(n,dx,incx,dy,incy)
c
c copies a vector, x, to a vector, y.
@@ -2210,7 +2234,7 @@ c
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 dcopy}
(defun dcopy (n dx incx dy incy)
@@ -2321,7 +2345,7 @@ NOTES
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{ddot.f}
double precision function ddot(n,dx,incx,dy,incy)
c
c forms the dot product of two vectors.
@@ -2372,7 +2396,7 @@ c
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 ddot}
(defun ddot (n dx incx dy incy)
@@ -2386,89 +2410,90 @@ c
(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)
+ (when (> n 0)
+ (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
+ (the fixnum (1- n)) incx)
+ 1)))
+ (if (< incy 0)
+ (setf iy
+ (f2cl-lib:int-add
+ (f2cl-lib:int-mul (the fixnum (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))
+ (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%))))))
+ (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)
+ (setf ddot dtemp))
end_label
(return (values ddot nil nil nil nil nil)))))
@@ -2542,7 +2567,7 @@ NOTES
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dnrm2.f}
DOUBLE PRECISION FUNCTION DNRM2 ( N, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, N
@@ -2604,7 +2629,7 @@ NOTES
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 dnrm2}
(let* ((one 1.0) (zero 0.0))
@@ -2630,10 +2655,7 @@ NOTES
((> ix
(f2cl-lib:int-add 1
(f2cl-lib:int-mul
- (f2cl-lib:int-add n
- (f2cl-lib:int-sub
- 1))
- incx)))
+ (the fixnum (1- n)) incx)))
nil)
(tagbody
(cond
@@ -2773,7 +2795,7 @@ Returns multiple values where:
\item 4 s - double-float
\end{itemize}
-\begin{verbatim}
+\begin{chunk}{drotg.f}
subroutine drotg(da,db,c,s)
c
c construct givens plane rotation.
@@ -2802,7 +2824,7 @@ c
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 drotg}
(defun drotg (da db c s)
@@ -2938,7 +2960,7 @@ NOTES
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{drot.f}
subroutine drot (n,dx,incx,dy,incy,c,s)
c
c applies a plane rotation.
@@ -2977,7 +2999,7 @@ c
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 drot}
(defun drot (n dx incx dy incy c s)
@@ -2996,12 +3018,12 @@ c
(if (< incx 0)
(setf ix
(f2cl-lib:int-add
- (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx)
+ (f2cl-lib:int-mul (the fixnum (1- n)) incx)
1)))
(if (< incy 0)
(setf iy
(f2cl-lib:int-add
- (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy)
+ (f2cl-lib:int-mul (the fixnum (1- n)) incy)
1)))
(f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
((> i n) nil)
@@ -3101,7 +3123,7 @@ NOTES
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dscal.f}
subroutine dscal(n,da,dx,incx)
c
c scales a vector by a constant.
@@ -3146,7 +3168,7 @@ c
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 dscal}
(defun dscal (n da dx incx)
@@ -3299,7 +3321,7 @@ NOTES
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dswap.f}
subroutine dswap (n,dx,incx,dy,incy)
c
c interchanges two vectors.
@@ -3357,7 +3379,7 @@ c
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 dswap}
(defun dswap (n dx incx dy incy)
@@ -3376,12 +3398,12 @@ c
(if (< incx 0)
(setf ix
(f2cl-lib:int-add
- (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx)
+ (f2cl-lib:int-mul (the fixnum (1- n)) incx)
1)))
(if (< incy 0)
(setf iy
(f2cl-lib:int-add
- (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy)
+ (f2cl-lib:int-mul (the fixnum (1- n)) incy)
1)))
(f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
((> i n) nil)
@@ -3539,7 +3561,7 @@ Return values are:
\item 3 nil
\end{itemize}
-\begin{verbatim}
+\begin{chunk}{dzasum.f}
double precision function dzasum(n,zx,incx)
c
c takes the sum of the absolute values.
@@ -3575,7 +3597,7 @@ c
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 dzasum}
(defun dzasum (n zx incx)
@@ -3684,7 +3706,7 @@ NOTES
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dznrm2.f}
DOUBLE PRECISION FUNCTION DZNRM2( N, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, N
@@ -3753,7 +3775,7 @@ NOTES
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 dznrm2}
(let* ((one 1.0) (zero 0.0))
@@ -3777,8 +3799,7 @@ NOTES
((> ix
(f2cl-lib:int-add 1
(f2cl-lib:int-mul
- (f2cl-lib:int-add n
- (f2cl-lib:int-sub 1))
+ (the fixnum (1- n))
incx)))
nil)
(tagbody
@@ -3893,7 +3914,7 @@ NOTES
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{icamax.f}
integer function icamax(n,cx,incx)
c
c finds the index of element having max. absolute value.
@@ -3938,7 +3959,7 @@ c
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 icamax}
(defun icamax (n cx incx)
@@ -4066,7 +4087,7 @@ NOTES
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{idamax.f}
integer function idamax(n,dx,incx)
c
c finds the index of element having max. absolute value.
@@ -4107,7 +4128,7 @@ c
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 idamax}
(defun idamax (n dx incx)
@@ -4249,7 +4270,7 @@ NOTES
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{isamax.f}
integer function isamax(n,sx,incx)
c
c finds the index of element having max. absolute value.
@@ -4290,7 +4311,7 @@ c
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 isamax}
(defun isamax (n sx incx)
@@ -4412,7 +4433,7 @@ NOTES
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{izamax.f}
integer function izamax(n,zx,incx)
c
c finds the index of element having max. absolute value.
@@ -4455,7 +4476,7 @@ c
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 izamax}
(defun izamax (n zx incx)
@@ -4617,7 +4638,7 @@ Return values are:
\item 6 nil
\end{itemize}
-\begin{verbatim}
+\begin{chunk}{zaxpy.f}
subroutine zaxpy(n,za,zx,incx,zy,incy)
c
c constant times a vector plus a vector.
@@ -4653,7 +4674,7 @@ c
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 zaxpy}
(defun zaxpy (n za zx incx zy incy)
@@ -4673,12 +4694,12 @@ c
(if (< incx 0)
(setf ix
(f2cl-lib:int-add
- (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx)
+ (f2cl-lib:int-mul (the fixnum (1- n)) incx)
1)))
(if (< incy 0)
(setf iy
(f2cl-lib:int-add
- (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy)
+ (f2cl-lib:int-mul (the fixnum (1- n)) incy)
1)))
(f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
((> i n) nil)
@@ -4779,7 +4800,7 @@ NOTES
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zcopy.f}
subroutine zcopy(n,zx,incx,zy,incy)
c
c copies a vector, x, to a vector, y.
@@ -4814,7 +4835,7 @@ c
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 zcopy}
(defun zcopy (n zx incx zy incy)
@@ -4832,12 +4853,12 @@ c
(if (< incx 0)
(setf ix
(f2cl-lib:int-add
- (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx)
+ (f2cl-lib:int-mul (the fixnum (1- n)) incx)
1)))
(if (< incy 0)
(setf iy
(f2cl-lib:int-add
- (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy)
+ (f2cl-lib:int-mul (the fixnum (1- n)) incy)
1)))
(f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
((> i n) nil)
@@ -4948,7 +4969,7 @@ NOTES
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zdotc.f}
double complex function zdotc(n,zx,incx,zy,incy)
c
c forms the dot product of a vector.
@@ -4986,7 +5007,7 @@ c
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 zdotc}
(defun zdotc (n zx incx zy incy)
@@ -5007,12 +5028,12 @@ c
(if (< incx 0)
(setf ix
(f2cl-lib:int-add
- (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx)
+ (f2cl-lib:int-mul (the fixnum (1- n)) incx)
1)))
(if (< incy 0)
(setf iy
(f2cl-lib:int-add
- (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy)
+ (f2cl-lib:int-mul (the fixnum (1- n)) incy)
1)))
(f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
((> i n) nil)
@@ -5126,7 +5147,7 @@ NOTES
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zdotu.f}
double complex function zdotu(n,zx,incx,zy,incy)
c
c forms the dot product of two vectors.
@@ -5164,7 +5185,7 @@ c
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 zdotu}
(defun zdotu (n zx incx zy incy)
@@ -5185,12 +5206,12 @@ c
(if (< incx 0)
(setf ix
(f2cl-lib:int-add
- (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx)
+ (f2cl-lib:int-mul (the fixnum (1- n)) incx)
1)))
(if (< incy 0)
(setf iy
(f2cl-lib:int-add
- (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy)
+ (f2cl-lib:int-mul (the fixnum (1- n)) incy)
1)))
(f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
((> i n) nil)
@@ -5289,7 +5310,7 @@ NOTES
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zdscal.f}
subroutine zdscal(n,da,zx,incx)
c
c scales a vector by a constant.
@@ -5321,7 +5342,7 @@ c
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 zdscal}
(defun zdscal (n da zx incx)
@@ -5471,7 +5492,7 @@ Returns multiple values where:
\item 4 s - s
\end{itemize}
-\begin{verbatim}
+\begin{chunk}{zrotg.f}
subroutine zrotg(ca,cb,c,s)
double complex ca,cb,s
double precision c
@@ -5494,7 +5515,7 @@ Returns multiple values where:
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 zrotg}
(defun zrotg (ca cb c s)
@@ -5597,7 +5618,7 @@ NOTES
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zscal.f}
subroutine zscal(n,za,zx,incx)
c
c scales a vector by a constant.
@@ -5628,7 +5649,7 @@ c
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 zscal}
(defun zscal (n za zx incx)
@@ -5736,7 +5757,7 @@ NOTES
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zswap.f}
subroutine zswap (n,zx,incx,zy,incy)
c
c interchanges two vectors.
@@ -5774,7 +5795,7 @@ c code for both increments equal to 1
return
end
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 1 zswap}
(defun zswap (n zx incx zy incy)
@@ -5793,12 +5814,12 @@ c code for both increments equal to 1
(if (< incx 0)
(setf ix
(f2cl-lib:int-add
- (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx)
+ (f2cl-lib:int-mul (the fixnum (1- n)) incx)
1)))
(if (< incy 0)
(setf iy
(f2cl-lib:int-add
- (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy)
+ (f2cl-lib:int-mul (the fixnum (1- n)) incy)
1)))
(f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
((> i n) nil)
@@ -5965,7 +5986,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgbmv.f}
SUBROUTINE DGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX,
$ BETA, Y, INCY )
* .. Scalar Arguments ..
@@ -6160,7 +6181,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 dgbmv}
(let* ((one 1.0) (zero 0.0))
@@ -6221,19 +6242,20 @@ Man Page Details
(setf kx 1))
(t
(setf kx
- (f2cl-lib:int-sub 1
+ (the fixnum (- 1
(f2cl-lib:int-mul
- (f2cl-lib:int-sub lenx 1)
- incx)))))
+ (the fixnum (1- lenx))
+ incx))))))
(cond
((> incy 0)
(setf ky 1))
(t
(setf ky
- (f2cl-lib:int-sub 1
+ (the fixnum (- 1
(f2cl-lib:int-mul
- (f2cl-lib:int-sub leny 1)
- incy)))))
+ (the fixnum (1- leny))
+ incy)))
+)))
(cond
((/= beta one)
(cond
@@ -6555,7 +6577,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgemv.f}
SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
$ BETA, Y, INCY )
* .. Scalar Arguments ..
@@ -6737,7 +6759,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 dgemv}
(let* ((one 1.0) (zero 0.0))
@@ -7056,7 +7078,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dger.f}
SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
@@ -7154,7 +7176,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 dger}
(let* ((zero 0.0))
@@ -7408,7 +7430,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dsbmv.f}
SUBROUTINE DSBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX,
$ BETA, Y, INCY )
* .. Scalar Arguments ..
@@ -7602,7 +7624,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 dsbmv}
(let* ((one 1.0) (zero 0.0))
@@ -8029,7 +8051,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dspmv.f}
SUBROUTINE DSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA, BETA
@@ -8217,7 +8239,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 dspmv}
(let* ((one 1.0) (zero 0.0))
@@ -8635,7 +8657,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dspr2.f}
SUBROUTINE DSPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
@@ -8791,7 +8813,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 dspr2}
(let* ((zero 0.0))
@@ -9163,7 +9185,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dspr.f}
SUBROUTINE DSPR ( UPLO, N, ALPHA, X, INCX, AP )
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
@@ -9299,7 +9321,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 dspr}
(let* ((zero 0.0))
@@ -9612,7 +9634,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dsymv.f}
SUBROUTINE DSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX,
$ BETA, Y, INCY )
* .. Scalar Arguments ..
@@ -9796,7 +9818,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 dsymv}
(let* ((one 1.0) (zero 0.0))
@@ -10193,7 +10215,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dsyr2.f}
SUBROUTINE DSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA )
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
@@ -10347,7 +10369,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 dsyr2}
(let* ((zero 0.0))
@@ -10701,7 +10723,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dsyr.f}
SUBROUTINE DSYR ( UPLO, N, ALPHA, X, INCX, A, LDA )
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
@@ -10833,7 +10855,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 dsyr}
(let* ((zero 0.0))
@@ -11158,7 +11180,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dtbmv.f}
SUBROUTINE DTBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, K, LDA, N
@@ -11383,7 +11405,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 dtbmv}
(let* ((zero 0.0))
@@ -11982,7 +12004,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dtbsv.f}
SUBROUTINE DTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, K, LDA, N
@@ -12207,7 +12229,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 dtbsv}
(let* ((zero 0.0))
@@ -12289,7 +12311,7 @@ Man Page Details
((1 lda) (1 *))
a-%offset%))))
(setf temp
- (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))
+ (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))
(f2cl-lib:fdo (i
(f2cl-lib:int-add j
(f2cl-lib:int-sub 1))
@@ -12299,7 +12321,7 @@ Man Page Details
(max (the fixnum 1)
(the fixnum
(f2cl-lib:int-add j
- (f2cl-lib:int-sub
+ (f2cl-lib:int-sub
k)))))
nil)
(tagbody
@@ -12361,7 +12383,7 @@ Man Page Details
(max (the fixnum 1)
(the fixnum
(f2cl-lib:int-add j
- (f2cl-lib:int-sub
+ (f2cl-lib:int-sub
k)))))
nil)
(tagbody
@@ -12770,7 +12792,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dtpmv.f}
SUBROUTINE DTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, N
@@ -12992,7 +13014,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 dtpmv}
(let* ((zero 0.0))
@@ -13557,7 +13579,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dtpsv.f}
SUBROUTINE DTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, N
@@ -13779,7 +13801,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 dtpsv}
(let* ((zero 0.0))
@@ -14344,7 +14366,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dtrmv.f}
SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, LDA, N
@@ -14550,7 +14572,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 dtrmv}
(let* ((zero 0.0))
@@ -15056,7 +15078,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dtrsv.f}
SUBROUTINE DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, LDA, N
@@ -15262,7 +15284,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 dtrsv}
(let* ((zero 0.0))
@@ -15794,7 +15816,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zgbmv.f}
SUBROUTINE ZGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX,
$ BETA, Y, INCY )
* .. Scalar Arguments ..
@@ -16007,7 +16029,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 zgbmv}
(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0)))
@@ -16461,7 +16483,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zgemv.f}
SUBROUTINE ZGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
$ BETA, Y, INCY )
* .. Scalar Arguments ..
@@ -16660,7 +16682,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 zgemv}
(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0)))
@@ -17018,7 +17040,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zgerc.f}
SUBROUTINE ZGERC ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
* .. Scalar Arguments ..
COMPLEX*16 ALPHA
@@ -17116,7 +17138,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 zgerc}
(let* ((zero (complex 0.0 0.0)))
@@ -17327,7 +17349,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zgeru.f}
SUBROUTINE ZGERU ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
* .. Scalar Arguments ..
COMPLEX*16 ALPHA
@@ -17425,7 +17447,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 zgeru}
(let* ((zero (complex 0.0 0.0)))
@@ -17682,7 +17704,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zhbmv.f}
SUBROUTINE ZHBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX,
$ BETA, Y, INCY )
* .. Scalar Arguments ..
@@ -17880,7 +17902,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 zhbmv}
(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0)))
@@ -18318,7 +18340,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zhemv.f}
SUBROUTINE ZHEMV ( UPLO, N, ALPHA, A, LDA, X, INCX,
$ BETA, Y, INCY )
* .. Scalar Arguments ..
@@ -18504,7 +18526,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 zhemv}
(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0)))
@@ -18911,7 +18933,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zher2.f}
SUBROUTINE ZHER2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA )
* .. Scalar Arguments ..
COMPLEX*16 ALPHA
@@ -19081,7 +19103,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 zher2}
(let* ((zero (complex 0.0 0.0)))
@@ -19614,7 +19636,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zher.f}
SUBROUTINE ZHER ( UPLO, N, ALPHA, X, INCX, A, LDA )
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
@@ -19758,7 +19780,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 zher}
(let* ((zero (complex 0.0 0.0)))
@@ -20193,7 +20215,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zhpmv.f}
SUBROUTINE ZHPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
* .. Scalar Arguments ..
COMPLEX*16 ALPHA, BETA
@@ -20386,7 +20408,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 zhpmv}
(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0)))
@@ -20813,7 +20835,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zhpr2.f}
SUBROUTINE ZHPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
* .. Scalar Arguments ..
COMPLEX*16 ALPHA
@@ -20988,7 +21010,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 zhpr2}
(let* ((zero (complex 0.0 0.0)))
@@ -21539,7 +21561,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zhpr.f}
SUBROUTINE ZHPR ( UPLO, N, ALPHA, X, INCX, AP )
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
@@ -21691,7 +21713,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 zhpr}
(let* ((zero (complex 0.0 0.0)))
@@ -22182,7 +22204,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{ztbmv.f}
SUBROUTINE ZTBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, K, LDA, N
@@ -22442,7 +22464,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 ztbmv}
(let* ((zero (complex 0.0 0.0)))
@@ -22751,7 +22773,7 @@ Man Page Details
(max (the fixnum 1)
(the fixnum
(f2cl-lib:int-add j
- (f2cl-lib:int-sub
+ (f2cl-lib:int-sub
k)))))
nil)
(tagbody
@@ -22785,7 +22807,7 @@ Man Page Details
(max (the fixnum 1)
(the fixnum
(f2cl-lib:int-add j
- (f2cl-lib:int-sub
+ (f2cl-lib:int-sub
k)))))
nil)
(tagbody
@@ -22837,7 +22859,7 @@ Man Page Details
(max (the fixnum 1)
(the fixnum
(f2cl-lib:int-add j
- (f2cl-lib:int-sub
+ (f2cl-lib:int-sub
k)))))
nil)
(tagbody
@@ -22872,7 +22894,7 @@ Man Page Details
(max (the fixnum 1)
(the fixnum
(f2cl-lib:int-add j
- (f2cl-lib:int-sub
+ (f2cl-lib:int-sub
k)))))
nil)
(tagbody
@@ -23192,7 +23214,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{ztbsv.f}
SUBROUTINE ZTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, K, LDA, N
@@ -23452,7 +23474,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 ztbsv}
(let* ((zero (complex 0.0 0.0)))
@@ -23545,7 +23567,7 @@ Man Page Details
(max (the fixnum 1)
(the fixnum
(f2cl-lib:int-add j
- (f2cl-lib:int-sub
+ (f2cl-lib:int-sub
k)))))
nil)
(tagbody
@@ -23607,7 +23629,7 @@ Man Page Details
(max (the fixnum 1)
(the fixnum
(f2cl-lib:int-add j
- (f2cl-lib:int-sub
+ (f2cl-lib:int-sub
k)))))
nil)
(tagbody
@@ -24164,7 +24186,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{ztpmv.f}
SUBROUTINE ZTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, N
@@ -24425,7 +24447,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 ztpmv}
(let* ((zero (complex 0.0 0.0)))
@@ -25126,7 +25148,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{ztpsv.f}
SUBROUTINE ZTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, N
@@ -25387,7 +25409,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 ztpsv}
(let* ((zero (complex 0.0 0.0)))
@@ -26100,7 +26122,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{ztrmv.f}
SUBROUTINE ZTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, LDA, N
@@ -26341,7 +26363,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 ztrmv}
(let* ((zero (complex 0.0 0.0)))
@@ -26971,7 +26993,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{ztrsv.f}
SUBROUTINE ZTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, LDA, N
@@ -27212,7 +27234,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 2 ztrsv}
(let* ((zero (complex 0.0 0.0)))
@@ -27878,7 +27900,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgemm.f}
SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
$ BETA, C, LDC )
* .. Scalar Arguments ..
@@ -28082,7 +28104,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 3 dgemm}
(let* ((one 1.0) (zero 0.0))
@@ -28120,9 +28142,11 @@ Man Page Details
(setf nrowb n)))
(setf info 0)
(cond
- ((and (not nota) (not (char-equal transa #\C)) (not (char-equal transa #\T)))
+ ((and (not nota) (not (char-equal transa #\C))
+ (not (char-equal transa #\T)))
(setf info 1))
- ((and (not notb) (not (char-equal transb #\C)) (not (char-equal transb #\T)))
+ ((and (not notb) (not (char-equal transb #\C))
+ (not (char-equal transb #\T)))
(setf info 2))
((< m 0)
(setf info 3))
@@ -28533,7 +28557,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dsymm.f}
SUBROUTINE DSYMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB,
$ BETA, C, LDC )
* .. Scalar Arguments ..
@@ -28714,7 +28738,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 3 dsymm}
(let* ((one 1.0) (zero 0.0))
@@ -29224,7 +29248,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dsyr2k.f}
SUBROUTINE DSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB,
$ BETA, C, LDC )
* .. Scalar Arguments ..
@@ -29436,7 +29460,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 3 dsyr2k}
(let* ((one 1.0) (zero 0.0))
@@ -29946,7 +29970,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dsyrk.f}
SUBROUTINE DSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA,
$ BETA, C, LDC )
* .. Scalar Arguments ..
@@ -30143,7 +30167,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 3 dsyrk}
(let* ((one 1.0) (zero 0.0))
@@ -30600,7 +30624,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dtrmm.f}
SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
$ B, LDB )
* .. Scalar Arguments ..
@@ -30850,7 +30874,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 3 dtrmm}
(let* ((one 1.0) (zero 0.0))
@@ -31489,7 +31513,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dtrsm.f}
SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
$ B, LDB )
* .. Scalar Arguments ..
@@ -31760,7 +31784,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 3 dtrsm}
(let* ((one 1.0) (zero 0.0))
@@ -32472,7 +32496,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zgemm.f}
SUBROUTINE ZGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
$ BETA, C, LDC )
* .. Scalar Arguments ..
@@ -32778,7 +32802,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 3 zgemm}
(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0)))
@@ -33455,7 +33479,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zhemm.f}
SUBROUTINE ZHEMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB,
$ BETA, C, LDC )
* .. Scalar Arguments ..
@@ -33644,7 +33668,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 3 zhemm}
(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0)))
@@ -34167,7 +34191,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zher2k.f}
SUBROUTINE ZHER2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA,
$ C, LDC )
* .. Scalar Arguments ..
@@ -34422,7 +34446,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 3 zher2k}
(let* ((one 1.0) (zero (complex 0.0 0.0)))
@@ -35153,7 +35177,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zherk.f}
SUBROUTINE ZHERK( UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC )
* .. Scalar Arguments ..
CHARACTER TRANS, UPLO
@@ -35385,7 +35409,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 3 zherk}
(let* ((one 1.0) (zero 0.0))
@@ -36069,7 +36093,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zsymm.f}
SUBROUTINE ZSYMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB,
$ BETA, C, LDC )
* .. Scalar Arguments ..
@@ -36252,7 +36276,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 3 zsymm}
(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0)))
@@ -36757,7 +36781,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zsyr2k.f}
SUBROUTINE ZSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB,
$ BETA, C, LDC )
* .. Scalar Arguments ..
@@ -36969,7 +36993,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 3 zsyr2k}
(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0)))
@@ -37475,7 +37499,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zsyrk.f}
SUBROUTINE ZSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA,
$ BETA, C, LDC )
* .. Scalar Arguments ..
@@ -37673,7 +37697,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 3 zsyrk}
(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0)))
@@ -38124,7 +38148,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{ztrmm.f}
SUBROUTINE ZTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
$ B, LDB )
* .. Scalar Arguments ..
@@ -38411,7 +38435,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 3 ztrmm}
(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0)))
@@ -39151,7 +39175,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{ztrsm.f}
SUBROUTINE ZTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
$ B, LDB )
* .. Scalar Arguments ..
@@ -39458,7 +39482,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{BLAS 3 ztrsm}
(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0)))
@@ -40319,7 +40343,7 @@ The return values are:
\calls{dbdsdc}{xerbla}
\calls{dbdsdc}{char-equal}
-\begin{verbatim}
+\begin{chunk}{dbdsdc.f}
SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ,
$ WORK, IWORK, INFO )
*
@@ -40635,7 +40659,7 @@ The return values are:
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dbdsdc}
(let* ((zero 0.0) (one 1.0) (two 2.0))
@@ -41224,7 +41248,7 @@ PARAMETERS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dbdsqr.f}
SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
$ LDU, C, LDC, WORK, INFO )
*
@@ -41845,7 +41869,7 @@ PARAMETERS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dbdsqr}
(let* ((zero 0.0)
@@ -43068,7 +43092,7 @@ ARGUMENTS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{ddisna.f}
SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -43198,7 +43222,7 @@ ARGUMENTS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK ddisna}
(let* ((zero 0.0))
@@ -43437,7 +43461,7 @@ ARGUMENTS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgebak.f}
SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
$ INFO )
*
@@ -43578,7 +43602,7 @@ ARGUMENTS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dgebak}
(let* ((one 1.0))
@@ -43822,7 +43846,7 @@ FURTHER DETAILS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgebal.f}
SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -44062,7 +44086,7 @@ FURTHER DETAILS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dgebal}
(let* ((zero 0.0) (one 1.0) (sclfac 8.0) (factor 0.95))
@@ -44425,7 +44449,7 @@ FURTHER DETAILS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgebd2.f}
SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -44556,7 +44580,7 @@ FURTHER DETAILS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dgebd2}
(let* ((zero 0.0) (one 1.0))
@@ -44925,7 +44949,7 @@ FURTHER DETAILS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgebrd.f}
SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK,
$ INFO )
*
@@ -45076,7 +45100,7 @@ FURTHER DETAILS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dgebrd}
(let* ((one 1.0))
@@ -45390,7 +45414,7 @@ ARGUMENTS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgeev.f}
SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR,
$ LDVR, WORK, LWORK, INFO )
*
@@ -45705,7 +45729,7 @@ ARGUMENTS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dgeev}
(let* ((zero 0.0) (one 1.0))
@@ -46449,7 +46473,7 @@ ARGUMENTS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgeevx.f}
SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI,
$ VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM,
$ RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )
@@ -46819,7 +46843,7 @@ ARGUMENTS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dgeevx}
(let* ((zero 0.0) (one 1.0))
@@ -47562,7 +47586,7 @@ FURTHER DETAILS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgehd2.f}
SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -47640,7 +47664,7 @@ FURTHER DETAILS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dgehd2}
(let* ((one 1.0))
@@ -47845,7 +47869,7 @@ FURTHER DETAILS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgehrd.f}
SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -48016,7 +48040,7 @@ FURTHER DETAILS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dgehrd}
(let* ((nbmax 64) (ldt (+ nbmax 1)) (zero 0.0) (one 1.0))
@@ -48276,7 +48300,7 @@ FURTHER DETAILS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgelq2.f}
SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -48349,7 +48373,7 @@ FURTHER DETAILS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dgelq2}
(let* ((one 1.0))
@@ -48514,7 +48538,7 @@ FURTHER DETAILS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgelqf.f}
SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -48650,7 +48674,7 @@ FURTHER DETAILS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dgelqf}
(defun dgelqf (m n a lda tau work lwork info)
@@ -48849,7 +48873,7 @@ FURTHER DETAILS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgeqr2.f}
SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -48922,7 +48946,7 @@ FURTHER DETAILS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dgeqr2}
(let* ((one 1.0))
@@ -49085,7 +49109,7 @@ FURTHER DETAILS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgeqrf.f}
SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -49221,7 +49245,7 @@ FURTHER DETAILS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dgeqrf}
(defun dgeqrf (m n a lda tau work lwork info)
@@ -49494,7 +49518,7 @@ ARGUMENTS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgesdd.f}
SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK,
$ LWORK, IWORK, INFO )
*
@@ -50706,7 +50730,7 @@ ARGUMENTS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dgesdd}
(let* ((zero 0.0) (one 1.0))
@@ -52754,525 +52778,3840 @@ SYNOPSIS
DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), VT(
LDVT, * ), WORK( * )
-PURPOSE
- DGESVD computes the singular value decomposition (SVD) of a real M-by-N
- matrix A, optionally computing the left and/or right singular vectors.
- The SVD is written
+ Purpose
+ =======
- A = U * SIGMA * transpose(V)
+ DGESVD computes the singular value decomposition (SVD) of a real
+ M-by-N matrix A, optionally computing the left and/or right singular
+ vectors. The SVD is written
- where SIGMA is an M-by-N matrix which is zero except for its min(m,n)
- diagonal elements, U is an M-by-M orthogonal matrix, and V is an N-by-N
- orthogonal matrix. The diagonal elements of SIGMA are the singular
- values of A; they are real and non-negative, and are returned in
- descending order. The first min(m,n) columns of U and V are the left
- and right singular vectors of A.
+ A = U * SIGMA * transpose(V)
- Note that the routine returns V**T, not V.
+ where SIGMA is an M-by-N matrix which is zero except for its
+ min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
+ V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA
+ are the singular values of A; they are real and non-negative, and
+ are returned in descending order. The first min(m,n) columns of
+ U and V are the left and right singular vectors of A.
+ Note that the routine returns V**T, not V.
-ARGUMENTS
- JOBU (input) CHARACTER*1
- Specifies options for computing all or part of the matrix U:
- = 'A': all M columns of U are returned in array U:
- = 'S': the first min(m,n) columns of U (the left singular vec-
- tors) are returned in the array U; = 'O': the first min(m,n)
- columns of U (the left singular vectors) are overwritten on the
- array A; = 'N': no columns of U (no left singular vectors) are
- computed.
-
- JOBVT (input) CHARACTER*1
- Specifies options for computing all or part of the matrix V**T:
- = 'A': all N rows of V**T are returned in the array VT;
- = 'S': the first min(m,n) rows of V**T (the right singular
- vectors) are returned in the array VT; = 'O': the first
- min(m,n) rows of V**T (the right singular vectors) are over-
- written on the array A; = 'N': no rows of V**T (no right sin-
- gular vectors) are computed.
-
- JOBVT and JOBU cannot both be 'O'.
+ Arguments
+ =========
- M (input) INTEGER
- The number of rows of the input matrix A. M >= 0.
+ JOBU (input) CHARACTER*1
+ Specifies options for computing all or part of the matrix U:
+ = 'A': all M columns of U are returned in array U:
+ = 'S': the first min(m,n) columns of U (the left singular
+ vectors) are returned in the array U;
+ = 'O': the first min(m,n) columns of U (the left singular
+ vectors) are overwritten on the array A;
+ = 'N': no columns of U (no left singular vectors) are
+ computed.
- N (input) INTEGER
- The number of columns of the input matrix A. N >= 0.
+ JOBVT (input) CHARACTER*1
+ Specifies options for computing all or part of the matrix
+ V**T:
+ = 'A': all N rows of V**T are returned in the array VT;
+ = 'S': the first min(m,n) rows of V**T (the right singular
+ vectors) are returned in the array VT;
+ = 'O': the first min(m,n) rows of V**T (the right singular
+ vectors) are overwritten on the array A;
+ = 'N': no rows of V**T (no right singular vectors) are
+ computed.
- A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
- On entry, the M-by-N matrix A. On exit, if JOBU = 'O', A is
- overwritten with the first min(m,n) columns of U (the left
- singular vectors, stored columnwise); if JOBVT = 'O', A is
- overwritten with the first min(m,n) rows of V**T (the right
- singular vectors, stored rowwise); if JOBU .ne. 'O' and JOBVT
- .ne. 'O', the contents of A are destroyed.
+ JOBVT and JOBU cannot both be 'O'.
- LDA (input) INTEGER
- The leading dimension of the array A. LDA >= max(1,M).
+ M (input) INTEGER
+ The number of rows of the input matrix A. M >= 0.
- S (output) DOUBLE PRECISION array, dimension (min(M,N))
- The singular values of A, sorted so that S(i) >= S(i+1).
+ N (input) INTEGER
+ The number of columns of the input matrix A. N >= 0.
- U (output) DOUBLE PRECISION array, dimension (LDU,UCOL)
- (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'. If JOBU
- = 'A', U contains the M-by-M orthogonal matrix U; if JOBU =
- 'S', U contains the first min(m,n) columns of U (the left sin-
- gular vectors, stored columnwise); if JOBU = 'N' or 'O', U is
- not referenced.
+ A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+ On entry, the M-by-N matrix A.
+ On exit,
+ if JOBU = 'O', A is overwritten with the first min(m,n)
+ columns of U (the left singular vectors,
+ stored columnwise);
+ if JOBVT = 'O', A is overwritten with the first min(m,n)
+ rows of V**T (the right singular vectors,
+ stored rowwise);
+ if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
+ are destroyed.
- LDU (input) INTEGER
- The leading dimension of the array U. LDU >= 1; if JOBU = 'S'
- or 'A', LDU >= M.
+ LDA (input) INTEGER
+ The leading dimension of the array A. LDA >= max(1,M).
- VT (output) DOUBLE PRECISION array, dimension (LDVT,N)
- If JOBVT = 'A', VT contains the N-by-N orthogonal matrix V**T;
- if JOBVT = 'S', VT contains the first min(m,n) rows of V**T
- (the right singular vectors, stored rowwise); if JOBVT = 'N' or
- 'O', VT is not referenced.
+ S (output) DOUBLE PRECISION array, dimension (min(M,N))
+ The singular values of A, sorted so that S(i) >= S(i+1).
- LDVT (input) INTEGER
- The leading dimension of the array VT. LDVT >= 1; if JOBVT =
- 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
+ U (output) DOUBLE PRECISION array, dimension (LDU,UCOL)
+ (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
+ If JOBU = 'A', U contains the M-by-M orthogonal matrix U;
+ if JOBU = 'S', U contains the first min(m,n) columns of U
+ (the left singular vectors, stored columnwise);
+ if JOBU = 'N' or 'O', U is not referenced.
- WORK (workspace/output) DOUBLE PRECISION array, dimension
- (MAX(1,LWORK))
- On exit, if INFO = 0, WORK(1) returns the optimal LWORK; if
- INFO > 0, WORK(2:MIN(M,N)) contains the unconverged superdiago-
- nal elements of an upper bidiagonal matrix B whose diagonal is
- in S (not necessarily sorted). B satisfies A = U * B * VT, so
- it has the same singular values as A, and singular vectors
- related by U and VT.
+ LDU (input) INTEGER
+ The leading dimension of the array U. LDU >= 1; if
+ JOBU = 'S' or 'A', LDU >= M.
- LWORK (input) INTEGER
- The dimension of the array WORK. LWORK >=
- MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)). For good performance,
- LWORK should generally be larger.
+ VT (output) DOUBLE PRECISION array, dimension (LDVT,N)
+ If JOBVT = 'A', VT contains the N-by-N orthogonal matrix
+ V**T;
+ if JOBVT = 'S', VT contains the first min(m,n) rows of
+ V**T (the right singular vectors, stored rowwise);
+ if JOBVT = 'N' or 'O', VT is not referenced.
- If LWORK = -1, then a workspace query is assumed; the routine
- only calculates the optimal size of the WORK array, returns
- this value as the first entry of the WORK array, and no error
- message related to LWORK is issued by XERBLA.
+ LDVT (input) INTEGER
+ The leading dimension of the array VT. LDVT >= 1; if
+ JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
- INFO (output) INTEGER
- = 0: successful exit.
- < 0: if INFO = -i, the i-th argument had an illegal value.
- > 0: if DBDSQR did not converge, INFO specifies how many
- superdiagonals of an intermediate bidiagonal form B did not
- converge to zero. See the description of WORK above for
- details.
+ WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
+ On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
+ if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged
+ superdiagonal elements of an upper bidiagonal matrix B
+ whose diagonal is in S (not necessarily sorted). B
+ satisfies A = U * B * VT, so it has the same singular values
+ as A, and singular vectors related by U and VT.
+
+ LWORK (input) INTEGER
+ The dimension of the array WORK. LWORK >= 1.
+ LWORK >= MAX(3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).
+ For good performance, LWORK should generally be larger.
+
+ If LWORK = -1, then a workspace query is assumed; the routine
+ only calculates the optimal size of the WORK array, returns
+ this value as the first entry of the WORK array, and no error
+ message related to LWORK is issued by XERBLA.
+
+ INFO (output) INTEGER
+ = 0: successful exit.
+ < 0: if INFO = -i, the i-th argument had an illegal value.
+ > 0: if DBDSQR did not converge, INFO specifies how many
+ superdiagonals of an intermediate bidiagonal form B
+ did not converge to zero. See the description of WORK
+ above for details.
\end{chunk}
-\begin{chunk}{LAPACK dgesvd}
-(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 (simple-array double-float (*)) work vt u s a)
- (type fixnum info lwork ldvt ldu lda n m)
- (type 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 (simple-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 (char-equal jobu #\A))
- (setf wntus (char-equal jobu #\S))
- (setf wntuas (or wntua wntus))
- (setf wntuo (char-equal jobu #\O))
- (setf wntun (char-equal jobu #\N))
- (setf wntva (char-equal jobvt #\A))
- (setf wntvs (char-equal jobvt #\S))
- (setf wntvas (or wntva wntvs))
- (setf wntvo (char-equal jobvt #\O))
- (setf wntvn (char-equal 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))))))
+\begin{chunk}{dgesvd.f}
+ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* Courant Institute, Argonne National Lab, and Rice University
+* October 31, 1999
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBU, JOBVT
+ INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ),
+ $ VT( LDVT, * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS,
+ $ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS
+ INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IR, ISCL,
+ $ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU,
+ $ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU,
+ $ NRVT, WRKBL
+ DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION DUM( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DBDSQR, DGEBRD, DGELQF, DGEMM, DGEQRF, DLACPY,
+ $ DLASCL, DLASET, DORGBR, DORGLQ, DORGQR, DORMBR,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ MINMN = MIN( M, N )
+ MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 )
+ WNTUA = LSAME( JOBU, 'A' )
+ WNTUS = LSAME( JOBU, 'S' )
+ WNTUAS = WNTUA .OR. WNTUS
+ WNTUO = LSAME( JOBU, 'O' )
+ WNTUN = LSAME( JOBU, 'N' )
+ WNTVA = LSAME( JOBVT, 'A' )
+ WNTVS = LSAME( JOBVT, 'S' )
+ WNTVAS = WNTVA .OR. WNTVS
+ WNTVO = LSAME( JOBVT, 'O' )
+ WNTVN = LSAME( JOBVT, 'N' )
+ MINWRK = 1
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR.
+ $ ( WNTVO .AND. WNTUO ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -6
+ ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN
+ INFO = -9
+ ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR.
+ $ ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN
+ INFO = -11
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.)
+*
+ IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) .AND. M.GT.0 .AND.
+ $ N.GT.0 ) THEN
+ IF( M.GE.N ) THEN
+*
+* Compute space needed for DBDSQR
+*
+ BDSPAC = 5*N
+ IF( M.GE.MNTHR ) THEN
+ IF( WNTUN ) THEN
+*
+* Path 1 (M much larger than N, JOBU='N')
+*
+ MAXWRK = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1,
+ $ -1 )
+ MAXWRK = MAX( MAXWRK, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ IF( WNTVO .OR. WNTVAS )
+ $ MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, BDSPAC )
+ MINWRK = MAX( 4*N, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ ELSE IF( WNTUO .AND. WNTVN ) THEN
+*
+* Path 2 (M much larger than N, JOBU='O', JOBVT='N')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
+ $ N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N )
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ ELSE IF( WNTUO .AND. WNTVAS ) THEN
+*
+* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or
+* 'A')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
+ $ N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N )
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ ELSE IF( WNTUS .AND. WNTVN ) THEN
+*
+* Path 4 (M much larger than N, JOBU='S', JOBVT='N')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
+ $ N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = N*N + WRKBL
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ ELSE IF( WNTUS .AND. WNTVO ) THEN
+*
+* Path 5 (M much larger than N, JOBU='S', JOBVT='O')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
+ $ N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = 2*N*N + WRKBL
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ ELSE IF( WNTUS .AND. WNTVAS ) THEN
+*
+* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or
+* 'A')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
+ $ N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = N*N + WRKBL
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ ELSE IF( WNTUA .AND. WNTVN ) THEN
+*
+* Path 7 (M much larger than N, JOBU='A', JOBVT='N')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
+ $ M, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = N*N + WRKBL
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ ELSE IF( WNTUA .AND. WNTVO ) THEN
+*
+* Path 8 (M much larger than N, JOBU='A', JOBVT='O')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
+ $ M, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = 2*N*N + WRKBL
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ ELSE IF( WNTUA .AND. WNTVAS ) THEN
+*
+* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or
+* 'A')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
+ $ M, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = N*N + WRKBL
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ END IF
+ ELSE
+*
+* Path 10 (M at least N, but not much larger)
+*
+ MAXWRK = 3*N + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N,
+ $ -1, -1 )
+ IF( WNTUS .OR. WNTUO )
+ $ MAXWRK = MAX( MAXWRK, 3*N+N*
+ $ ILAENV( 1, 'DORGBR', 'Q', M, N, N, -1 ) )
+ IF( WNTUA )
+ $ MAXWRK = MAX( MAXWRK, 3*N+M*
+ $ ILAENV( 1, 'DORGBR', 'Q', M, M, N, -1 ) )
+ IF( .NOT.WNTVN )
+ $ MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, BDSPAC )
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ END IF
+ ELSE
+*
+* Compute space needed for DBDSQR
+*
+ BDSPAC = 5*M
+ IF( N.GE.MNTHR ) THEN
+ IF( WNTVN ) THEN
+*
+* Path 1t(N much larger than M, JOBVT='N')
+*
+ MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1,
+ $ -1 )
+ MAXWRK = MAX( MAXWRK, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ IF( WNTUO .OR. WNTUAS )
+ $ MAXWRK = MAX( MAXWRK, 3*M+M*
+ $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, BDSPAC )
+ MINWRK = MAX( 4*M, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ ELSE IF( WNTVO .AND. WNTUN ) THEN
+*
+* Path 2t(N much larger than M, JOBU='N', JOBVT='O')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M )
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ ELSE IF( WNTVO .AND. WNTUAS ) THEN
+*
+* Path 3t(N much larger than M, JOBU='S' or 'A',
+* JOBVT='O')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M )
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ ELSE IF( WNTVS .AND. WNTUN ) THEN
+*
+* Path 4t(N much larger than M, JOBU='N', JOBVT='S')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = M*M + WRKBL
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ ELSE IF( WNTVS .AND. WNTUO ) THEN
+*
+* Path 5t(N much larger than M, JOBU='O', JOBVT='S')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = 2*M*M + WRKBL
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ ELSE IF( WNTVS .AND. WNTUAS ) THEN
+*
+* Path 6t(N much larger than M, JOBU='S' or 'A',
+* JOBVT='S')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = M*M + WRKBL
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ ELSE IF( WNTVA .AND. WNTUN ) THEN
+*
+* Path 7t(N much larger than M, JOBU='N', JOBVT='A')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = M*M + WRKBL
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ ELSE IF( WNTVA .AND. WNTUO ) THEN
+*
+* Path 8t(N much larger than M, JOBU='O', JOBVT='A')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = 2*M*M + WRKBL
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ ELSE IF( WNTVA .AND. WNTUAS ) THEN
+*
+* Path 9t(N much larger than M, JOBU='S' or 'A',
+* JOBVT='A')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = M*M + WRKBL
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ END IF
+ ELSE
+*
+* Path 10t(N greater than M, but not much larger)
+*
+ MAXWRK = 3*M + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N,
+ $ -1, -1 )
+ IF( WNTVS .OR. WNTVO )
+ $ MAXWRK = MAX( MAXWRK, 3*M+M*
+ $ ILAENV( 1, 'DORGBR', 'P', M, N, M, -1 ) )
+ IF( WNTVA )
+ $ MAXWRK = MAX( MAXWRK, 3*M+N*
+ $ ILAENV( 1, 'DORGBR', 'P', N, N, M, -1 ) )
+ IF( .NOT.WNTUN )
+ $ MAXWRK = MAX( MAXWRK, 3*M+( M-1 )*
+ $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, BDSPAC )
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ END IF
+ END IF
+ WORK( 1 ) = MAXWRK
+ END IF
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGESVD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ IF( LWORK.GE.1 )
+ $ WORK( 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = DLANGE( 'M', M, N, A, LDA, DUM )
+ ISCL = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ ISCL = 1
+ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ ISCL = 1
+ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
+ END IF
+*
+ IF( M.GE.N ) THEN
+*
+* A has at least as many rows as columns. If A has sufficiently
+* more rows than columns, first reduce using the QR
+* decomposition (if sufficient workspace available)
+*
+ IF( M.GE.MNTHR ) THEN
+*
+ IF( WNTUN ) THEN
+*
+* Path 1 (M much larger than N, JOBU='N')
+* No left singular vectors to be computed
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Zero out below R
+*
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
+ IE = 1
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in A
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+ $ IERR )
+ NCVT = 0
+ IF( WNTVO .OR. WNTVAS ) THEN
+*
+* If right singular vectors desired, generate P'.
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ NCVT = N
+ END IF
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of A in A if desired
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, NCVT, 0, 0, S, WORK( IE ), A, LDA,
+ $ DUM, 1, DUM, 1, WORK( IWORK ), INFO )
+*
+* If right singular vectors desired in VT, copy them there
+*
+ IF( WNTVAS )
+ $ CALL DLACPY( 'F', N, N, A, LDA, VT, LDVT )
+*
+ ELSE IF( WNTUO .AND. WNTVN ) THEN
+*
+* Path 2 (M much larger than N, JOBU='O', JOBVT='N')
+* N left singular vectors to be overwritten on A and
+* no right singular vectors to be computed
+*
+ IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN
+*
+* WORK(IU) is LDA by N, WORK(IR) is LDA by N
+*
+ LDWRKU = LDA
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN
+*
+* WORK(IU) is LDA by N, WORK(IR) is N by N
+*
+ LDWRKU = LDA
+ LDWRKR = N
+ ELSE
+*
+* WORK(IU) is LDWRKU by N, WORK(IR) is N by N
+*
+ LDWRKU = ( LWORK-N*N-N ) / N
+ LDWRKR = N
+ END IF
+ ITAU = IR + LDWRKR*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to WORK(IR) and zero out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
+ $ LDWRKR )
+*
+* Generate Q in A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate left vectors bidiagonalizing R
+* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+ CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IR)
+* (Workspace: need N*N+BDSPAC)
+*
+ CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, 1,
+ $ WORK( IR ), LDWRKR, DUM, 1,
+ $ WORK( IWORK ), INFO )
+ IU = IE + N
+*
+* Multiply Q in A by left singular vectors of R in
+* WORK(IR), storing result in WORK(IU) and copying to A
+* (Workspace: need N*N+2*N, prefer N*N+M*N+N)
+*
+ DO 10 I = 1, M, LDWRKU
+ CHUNK = MIN( M-I+1, LDWRKU )
+ CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
+ $ LDA, WORK( IR ), LDWRKR, ZERO,
+ $ WORK( IU ), LDWRKU )
+ CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
+ $ A( I, 1 ), LDA )
+ 10 CONTINUE
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ IE = 1
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize A
+* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
+*
+ CALL DGEBRD( M, N, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate left vectors bidiagonalizing A
+* (Workspace: need 4*N, prefer 3*N+N*NB)
+*
+ CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in A
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, 1,
+ $ A, LDA, DUM, 1, WORK( IWORK ), INFO )
+*
+ END IF
+*
+ ELSE IF( WNTUO .AND. WNTVAS ) THEN
+*
+* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A')
+* N left singular vectors to be overwritten on A and
+* N right singular vectors to be computed in VT
+*
+ IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is LDA by N
+*
+ LDWRKU = LDA
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is N by N
+*
+ LDWRKU = LDA
+ LDWRKR = N
+ ELSE
+*
+* WORK(IU) is LDWRKU by N and WORK(IR) is N by N
+*
+ LDWRKU = ( LWORK-N*N-N ) / N
+ LDWRKR = N
+ END IF
+ ITAU = IR + LDWRKR*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to VT, zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, VT( 2, 1 ),
+ $ LDVT )
+*
+* Generate Q in A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in VT, copying result to WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR )
+*
+* Generate left vectors bidiagonalizing R in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+ CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right vectors bidiagonalizing R in VT
+* (Workspace: need N*N+4*N-1, prefer N*N+3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IR) and computing right
+* singular vectors of R in VT
+* (Workspace: need N*N+BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, LDVT,
+ $ WORK( IR ), LDWRKR, DUM, 1,
+ $ WORK( IWORK ), INFO )
+ IU = IE + N
+*
+* Multiply Q in A by left singular vectors of R in
+* WORK(IR), storing result in WORK(IU) and copying to A
+* (Workspace: need N*N+2*N, prefer N*N+M*N+N)
+*
+ DO 20 I = 1, M, LDWRKU
+ CHUNK = MIN( M-I+1, LDWRKU )
+ CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
+ $ LDA, WORK( IR ), LDWRKR, ZERO,
+ $ WORK( IU ), LDWRKU )
+ CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
+ $ A( I, 1 ), LDA )
+ 20 CONTINUE
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to VT, zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, VT( 2, 1 ),
+ $ LDVT )
+*
+* Generate Q in A
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in VT
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in A by left vectors bidiagonalizing R
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
+ $ WORK( ITAUQ ), A, LDA, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right vectors bidiagonalizing R in VT
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in A and computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, LDVT,
+ $ A, LDA, DUM, 1, WORK( IWORK ), INFO )
+*
+ END IF
+*
+ ELSE IF( WNTUS ) THEN
+*
+ IF( WNTVN ) THEN
+*
+* Path 4 (M much larger than N, JOBU='S', JOBVT='N')
+* N left singular vectors to be computed in U and
+* no right singular vectors to be computed
+*
+ IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+* WORK(IR) is LDA by N
+*
+ LDWRKR = LDA
+ ELSE
+*
+* WORK(IR) is N by N
+*
+ LDWRKR = N
+ END IF
+ ITAU = IR + LDWRKR*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to WORK(IR), zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ),
+ $ LDWRKR )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ WORK( IR+1 ), LDWRKR )
+*
+* Generate Q in A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left vectors bidiagonalizing R in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+ CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IR)
+* (Workspace: need N*N+BDSPAC)
+*
+ CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM,
+ $ 1, WORK( IR ), LDWRKR, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply Q in A by left singular vectors of R in
+* WORK(IR), storing result in U
+* (Workspace: need N*N)
+*
+ CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
+ $ WORK( IR ), LDWRKR, ZERO, U, LDU )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Zero out below R in A
+*
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
+ $ LDA )
+*
+* Bidiagonalize R in A
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in U by left vectors bidiagonalizing R
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM,
+ $ 1, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTVO ) THEN
+*
+* Path 5 (M much larger than N, JOBU='S', JOBVT='O')
+* N left singular vectors to be computed in U and
+* N right singular vectors to be overwritten on A
+*
+ IF( LWORK.GE.2*N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is LDA by N
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*N
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is N by N
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*N
+ LDWRKR = N
+ ELSE
+*
+* WORK(IU) is N by N and WORK(IR) is N by N
+*
+ LDWRKU = N
+ IR = IU + LDWRKU*N
+ LDWRKR = N
+ END IF
+ ITAU = IR + LDWRKR*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to WORK(IU), zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ WORK( IU+1 ), LDWRKU )
+*
+* Generate Q in A
+* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
+*
+ CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IU), copying result to
+* WORK(IR)
+* (Workspace: need 2*N*N+4*N,
+* prefer 2*N*N+3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU,
+ $ WORK( IR ), LDWRKR )
+*
+* Generate left bidiagonalizing vectors in WORK(IU)
+* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB)
+*
+ CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in WORK(IR)
+* (Workspace: need 2*N*N+4*N-1,
+* prefer 2*N*N+3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IU) and computing
+* right singular vectors of R in WORK(IR)
+* (Workspace: need 2*N*N+BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ),
+ $ WORK( IR ), LDWRKR, WORK( IU ),
+ $ LDWRKU, DUM, 1, WORK( IWORK ), INFO )
+*
+* Multiply Q in A by left singular vectors of R in
+* WORK(IU), storing result in U
+* (Workspace: need N*N)
+*
+ CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
+ $ WORK( IU ), LDWRKU, ZERO, U, LDU )
+*
+* Copy right singular vectors of R to A
+* (Workspace: need N*N)
+*
+ CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
+ $ LDA )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Zero out below R in A
+*
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
+ $ LDA )
+*
+* Bidiagonalize R in A
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in U by left vectors bidiagonalizing R
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right vectors bidiagonalizing R in A
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in A
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A,
+ $ LDA, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTVAS ) THEN
+*
+* Path 6 (M much larger than N, JOBU='S', JOBVT='S'
+* or 'A')
+* N left singular vectors to be computed in U and
+* N right singular vectors to be computed in VT
+*
+ IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+* WORK(IU) is LDA by N
+*
+ LDWRKU = LDA
+ ELSE
+*
+* WORK(IU) is N by N
+*
+ LDWRKU = N
+ END IF
+ ITAU = IU + LDWRKU*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to WORK(IU), zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ WORK( IU+1 ), LDWRKU )
+*
+* Generate Q in A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IU), copying result to VT
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
+ $ LDVT )
+*
+* Generate left bidiagonalizing vectors in WORK(IU)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+ CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in VT
+* (Workspace: need N*N+4*N-1,
+* prefer N*N+3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IU) and computing
+* right singular vectors of R in VT
+* (Workspace: need N*N+BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT,
+ $ LDVT, WORK( IU ), LDWRKU, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply Q in A by left singular vectors of R in
+* WORK(IU), storing result in U
+* (Workspace: need N*N)
+*
+ CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
+ $ WORK( IU ), LDWRKU, ZERO, U, LDU )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to VT, zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, VT( 2, 1 ),
+ $ LDVT )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in VT
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in U by left bidiagonalizing vectors
+* in VT
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
+ $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in VT
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT,
+ $ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ END IF
+*
+ ELSE IF( WNTUA ) THEN
+*
+ IF( WNTVN ) THEN
+*
+* Path 7 (M much larger than N, JOBU='A', JOBVT='N')
+* M left singular vectors to be computed in U and
+* no right singular vectors to be computed
+*
+ IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+* WORK(IR) is LDA by N
+*
+ LDWRKR = LDA
+ ELSE
+*
+* WORK(IR) is N by N
+*
+ LDWRKR = N
+ END IF
+ ITAU = IR + LDWRKR*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Copy R to WORK(IR), zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ),
+ $ LDWRKR )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ WORK( IR+1 ), LDWRKR )
+*
+* Generate Q in U
+* (Workspace: need N*N+N+M, prefer N*N+N+M*NB)
+*
+ CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+ CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IR)
+* (Workspace: need N*N+BDSPAC)
+*
+ CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM,
+ $ 1, WORK( IR ), LDWRKR, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply Q in U by left singular vectors of R in
+* WORK(IR), storing result in A
+* (Workspace: need N*N)
+*
+ CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
+ $ WORK( IR ), LDWRKR, ZERO, A, LDA )
+*
+* Copy left singular vectors of A from A to U
+*
+ CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need N+M, prefer N+M*NB)
+*
+ CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Zero out below R in A
+*
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
+ $ LDA )
+*
+* Bidiagonalize R in A
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in U by left bidiagonalizing vectors
+* in A
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM,
+ $ 1, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTVO ) THEN
+*
+* Path 8 (M much larger than N, JOBU='A', JOBVT='O')
+* M left singular vectors to be computed in U and
+* N right singular vectors to be overwritten on A
+*
+ IF( LWORK.GE.2*N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is LDA by N
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*N
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is N by N
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*N
+ LDWRKR = N
+ ELSE
+*
+* WORK(IU) is N by N and WORK(IR) is N by N
+*
+ LDWRKU = N
+ IR = IU + LDWRKU*N
+ LDWRKR = N
+ END IF
+ ITAU = IR + LDWRKR*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB)
+*
+ CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to WORK(IU), zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ WORK( IU+1 ), LDWRKU )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IU), copying result to
+* WORK(IR)
+* (Workspace: need 2*N*N+4*N,
+* prefer 2*N*N+3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU,
+ $ WORK( IR ), LDWRKR )
+*
+* Generate left bidiagonalizing vectors in WORK(IU)
+* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB)
+*
+ CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in WORK(IR)
+* (Workspace: need 2*N*N+4*N-1,
+* prefer 2*N*N+3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IU) and computing
+* right singular vectors of R in WORK(IR)
+* (Workspace: need 2*N*N+BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ),
+ $ WORK( IR ), LDWRKR, WORK( IU ),
+ $ LDWRKU, DUM, 1, WORK( IWORK ), INFO )
+*
+* Multiply Q in U by left singular vectors of R in
+* WORK(IU), storing result in A
+* (Workspace: need N*N)
+*
+ CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
+ $ WORK( IU ), LDWRKU, ZERO, A, LDA )
+*
+* Copy left singular vectors of A from A to U
+*
+ CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+* Copy right singular vectors of R from WORK(IR) to A
+*
+ CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
+ $ LDA )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need N+M, prefer N+M*NB)
+*
+ CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Zero out below R in A
+*
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
+ $ LDA )
+*
+* Bidiagonalize R in A
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in U by left bidiagonalizing vectors
+* in A
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in A
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in A
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A,
+ $ LDA, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTVAS ) THEN
+*
+* Path 9 (M much larger than N, JOBU='A', JOBVT='S'
+* or 'A')
+* M left singular vectors to be computed in U and
+* N right singular vectors to be computed in VT
+*
+ IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+* WORK(IU) is LDA by N
+*
+ LDWRKU = LDA
+ ELSE
+*
+* WORK(IU) is N by N
+*
+ LDWRKU = N
+ END IF
+ ITAU = IU + LDWRKU*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need N*N+N+M, prefer N*N+N+M*NB)
+*
+ CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to WORK(IU), zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ WORK( IU+1 ), LDWRKU )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IU), copying result to VT
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
+ $ LDVT )
+*
+* Generate left bidiagonalizing vectors in WORK(IU)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+ CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in VT
+* (Workspace: need N*N+4*N-1,
+* prefer N*N+3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IU) and computing
+* right singular vectors of R in VT
+* (Workspace: need N*N+BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT,
+ $ LDVT, WORK( IU ), LDWRKU, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply Q in U by left singular vectors of R in
+* WORK(IU), storing result in A
+* (Workspace: need N*N)
+*
+ CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
+ $ WORK( IU ), LDWRKU, ZERO, A, LDA )
+*
+* Copy left singular vectors of A from A to U
+*
+ CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need N+M, prefer N+M*NB)
+*
+ CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R from A to VT, zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, VT( 2, 1 ),
+ $ LDVT )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in VT
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in U by left bidiagonalizing vectors
+* in VT
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
+ $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in VT
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT,
+ $ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ END IF
+*
+ END IF
+*
+ ELSE
+*
+* M .LT. MNTHR
+*
+* Path 10 (M at least N, but not much larger)
+* Reduce to bidiagonal form without QR decomposition
+*
+ IE = 1
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize A
+* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
+*
+ CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+ $ IERR )
+ IF( WNTUAS ) THEN
+*
+* If left singular vectors desired in U, copy result to U
+* and generate left bidiagonalizing vectors in U
+* (Workspace: need 3*N+NCU, prefer 3*N+NCU*NB)
+*
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+ IF( WNTUS )
+ $ NCU = N
+ IF( WNTUA )
+ $ NCU = M
+ CALL DORGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IF( WNTVAS ) THEN
+*
+* If right singular vectors desired in VT, copy result to
+* VT and generate right bidiagonalizing vectors in VT
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
+ CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IF( WNTUO ) THEN
+*
+* If left singular vectors desired in A, generate left
+* bidiagonalizing vectors in A
+* (Workspace: need 4*N, prefer 3*N+N*NB)
+*
+ CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IF( WNTVO ) THEN
+*
+* If right singular vectors desired in A, generate right
+* bidiagonalizing vectors in A
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IWORK = IE + N
+ IF( WNTUAS .OR. WNTUO )
+ $ NRU = M
+ IF( WNTUN )
+ $ NRU = 0
+ IF( WNTVAS .OR. WNTVO )
+ $ NCVT = N
+ IF( WNTVN )
+ $ NCVT = 0
+ IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
+*
+* Perform bidiagonal QR iteration, if desired, computing
+* left singular vectors in U and computing right singular
+* vectors in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT,
+ $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO )
+ ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
+*
+* Perform bidiagonal QR iteration, if desired, computing
+* left singular vectors in U and computing right singular
+* vectors in A
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), A, LDA,
+ $ U, LDU, DUM, 1, WORK( IWORK ), INFO )
+ ELSE
+*
+* Perform bidiagonal QR iteration, if desired, computing
+* left singular vectors in A and computing right singular
+* vectors in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT,
+ $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO )
+ END IF
+*
+ END IF
+*
+ ELSE
+*
+* A has more columns than rows. If A has sufficiently more
+* columns than rows, first reduce using the LQ decomposition (if
+* sufficient workspace available)
+*
+ IF( N.GE.MNTHR ) THEN
+*
+ IF( WNTVN ) THEN
+*
+* Path 1t(N much larger than M, JOBVT='N')
+* No right singular vectors to be computed
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Zero out above L
+*
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
+ IE = 1
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in A
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+ $ IERR )
+ IF( WNTUO .OR. WNTUAS ) THEN
+*
+* If left singular vectors desired, generate Q
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IWORK = IE + M
+ NRU = 0
+ IF( WNTUO .OR. WNTUAS )
+ $ NRU = M
+*
+* Perform bidiagonal QR iteration, computing left singular
+* vectors of A in A if desired
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', M, 0, NRU, 0, S, WORK( IE ), DUM, 1, A,
+ $ LDA, DUM, 1, WORK( IWORK ), INFO )
+*
+* If left singular vectors desired in U, copy them there
+*
+ IF( WNTUAS )
+ $ CALL DLACPY( 'F', M, M, A, LDA, U, LDU )
+*
+ ELSE IF( WNTVO .AND. WNTUN ) THEN
+*
+* Path 2t(N much larger than M, JOBU='N', JOBVT='O')
+* M right singular vectors to be overwritten on A and
+* no left singular vectors to be computed
+*
+ IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is LDA by M
+*
+ LDWRKU = LDA
+ CHUNK = N
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is M by M
+*
+ LDWRKU = LDA
+ CHUNK = N
+ LDWRKR = M
+ ELSE
+*
+* WORK(IU) is M by CHUNK and WORK(IR) is M by M
+*
+ LDWRKU = M
+ CHUNK = ( LWORK-M*M-M ) / M
+ LDWRKR = M
+ END IF
+ ITAU = IR + LDWRKR*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to WORK(IR) and zero out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IR+LDWRKR ), LDWRKR )
+*
+* Generate Q in A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IR)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate right vectors bidiagonalizing L
+* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
+*
+ CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of L in WORK(IR)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
+ $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
+ $ WORK( IWORK ), INFO )
+ IU = IE + M
+*
+* Multiply right singular vectors of L in WORK(IR) by Q
+* in A, storing result in WORK(IU) and copying to A
+* (Workspace: need M*M+2*M, prefer M*M+M*N+M)
+*
+ DO 30 I = 1, N, CHUNK
+ BLK = MIN( N-I+1, CHUNK )
+ CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ),
+ $ LDWRKR, A( 1, I ), LDA, ZERO,
+ $ WORK( IU ), LDWRKU )
+ CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
+ $ A( 1, I ), LDA )
+ 30 CONTINUE
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ IE = 1
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize A
+* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
+*
+ CALL DGEBRD( M, N, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate right vectors bidiagonalizing A
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of A in A
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'L', M, N, 0, 0, S, WORK( IE ), A, LDA,
+ $ DUM, 1, DUM, 1, WORK( IWORK ), INFO )
+*
+ END IF
+*
+ ELSE IF( WNTVO .AND. WNTUAS ) THEN
+*
+* Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O')
+* M right singular vectors to be overwritten on A and
+* M left singular vectors to be computed in U
+*
+ IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is LDA by M
+*
+ LDWRKU = LDA
+ CHUNK = N
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is M by M
+*
+ LDWRKU = LDA
+ CHUNK = N
+ LDWRKR = M
+ ELSE
+*
+* WORK(IU) is M by CHUNK and WORK(IR) is M by M
+*
+ LDWRKU = M
+ CHUNK = ( LWORK-M*M-M ) / M
+ LDWRKR = M
+ END IF
+ ITAU = IR + LDWRKR*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to U, zeroing about above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
+ $ LDU )
+*
+* Generate Q in A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in U, copying result to WORK(IR)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR )
+*
+* Generate right vectors bidiagonalizing L in WORK(IR)
+* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
+*
+ CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left vectors bidiagonalizing L in U
+* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of L in U, and computing right
+* singular vectors of L in WORK(IR)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+ $ WORK( IR ), LDWRKR, U, LDU, DUM, 1,
+ $ WORK( IWORK ), INFO )
+ IU = IE + M
+*
+* Multiply right singular vectors of L in WORK(IR) by Q
+* in A, storing result in WORK(IU) and copying to A
+* (Workspace: need M*M+2*M, prefer M*M+M*N+M))
+*
+ DO 40 I = 1, N, CHUNK
+ BLK = MIN( N-I+1, CHUNK )
+ CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ),
+ $ LDWRKR, A( 1, I ), LDA, ZERO,
+ $ WORK( IU ), LDWRKU )
+ CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
+ $ A( 1, I ), LDA )
+ 40 CONTINUE
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to U, zeroing out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
+ $ LDU )
+*
+* Generate Q in A
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in U
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right vectors bidiagonalizing L by Q in A
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
+ $ WORK( ITAUP ), A, LDA, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left vectors bidiagonalizing L in U
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in A
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), A, LDA,
+ $ U, LDU, DUM, 1, WORK( IWORK ), INFO )
+*
+ END IF
+*
+ ELSE IF( WNTVS ) THEN
+*
+ IF( WNTUN ) THEN
+*
+* Path 4t(N much larger than M, JOBU='N', JOBVT='S')
+* M right singular vectors to be computed in VT and
+* no left singular vectors to be computed
+*
+ IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+* WORK(IR) is LDA by M
+*
+ LDWRKR = LDA
+ ELSE
+*
+* WORK(IR) is M by M
+*
+ LDWRKR = M
+ END IF
+ ITAU = IR + LDWRKR*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to WORK(IR), zeroing out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ),
+ $ LDWRKR )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IR+LDWRKR ), LDWRKR )
+*
+* Generate Q in A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IR)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right vectors bidiagonalizing L in
+* WORK(IR)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB)
+*
+ CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of L in WORK(IR)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
+ $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply right singular vectors of L in WORK(IR) by
+* Q in A, storing result in VT
+* (Workspace: need M*M)
+*
+ CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ),
+ $ LDWRKR, A, LDA, ZERO, VT, LDVT )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy result to VT
+*
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Zero out above L in A
+*
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
+ $ LDA )
+*
+* Bidiagonalize L in A
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right vectors bidiagonalizing L by Q in VT
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT,
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT,
+ $ LDVT, DUM, 1, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTUO ) THEN
+*
+* Path 5t(N much larger than M, JOBU='O', JOBVT='S')
+* M right singular vectors to be computed in VT and
+* M left singular vectors to be overwritten on A
+*
+ IF( LWORK.GE.2*M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
+*
+* WORK(IU) is LDA by M and WORK(IR) is LDA by M
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*M
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
+*
+* WORK(IU) is LDA by M and WORK(IR) is M by M
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*M
+ LDWRKR = M
+ ELSE
+*
+* WORK(IU) is M by M and WORK(IR) is M by M
+*
+ LDWRKU = M
+ IR = IU + LDWRKU*M
+ LDWRKR = M
+ END IF
+ ITAU = IR + LDWRKR*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to WORK(IU), zeroing out below it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IU+LDWRKU ), LDWRKU )
+*
+* Generate Q in A
+* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
+*
+ CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IU), copying result to
+* WORK(IR)
+* (Workspace: need 2*M*M+4*M,
+* prefer 2*M*M+3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU,
+ $ WORK( IR ), LDWRKR )
+*
+* Generate right bidiagonalizing vectors in WORK(IU)
+* (Workspace: need 2*M*M+4*M-1,
+* prefer 2*M*M+3*M+(M-1)*NB)
+*
+ CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in WORK(IR)
+* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of L in WORK(IR) and computing
+* right singular vectors of L in WORK(IU)
+* (Workspace: need 2*M*M+BDSPAC)
+*
+ CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+ $ WORK( IU ), LDWRKU, WORK( IR ),
+ $ LDWRKR, DUM, 1, WORK( IWORK ), INFO )
+*
+* Multiply right singular vectors of L in WORK(IU) by
+* Q in A, storing result in VT
+* (Workspace: need M*M)
+*
+ CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
+ $ LDWRKU, A, LDA, ZERO, VT, LDVT )
+*
+* Copy left singular vectors of L to A
+* (Workspace: need M*M)
+*
+ CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
+ $ LDA )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Zero out above L in A
+*
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
+ $ LDA )
+*
+* Bidiagonalize L in A
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right vectors bidiagonalizing L by Q in VT
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT,
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors of L in A
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, compute left
+* singular vectors of A in A and compute right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
+ $ LDVT, A, LDA, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTUAS ) THEN
+*
+* Path 6t(N much larger than M, JOBU='S' or 'A',
+* JOBVT='S')
+* M right singular vectors to be computed in VT and
+* M left singular vectors to be computed in U
+*
+ IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+* WORK(IU) is LDA by N
+*
+ LDWRKU = LDA
+ ELSE
+*
+* WORK(IU) is LDA by M
+*
+ LDWRKU = M
+ END IF
+ ITAU = IU + LDWRKU*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to WORK(IU), zeroing out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IU+LDWRKU ), LDWRKU )
+*
+* Generate Q in A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IU), copying result to U
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
+ $ LDU )
+*
+* Generate right bidiagonalizing vectors in WORK(IU)
+* (Workspace: need M*M+4*M-1,
+* prefer M*M+3*M+(M-1)*NB)
+*
+ CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in U
+* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of L in U and computing right
+* singular vectors of L in WORK(IU)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+ $ WORK( IU ), LDWRKU, U, LDU, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply right singular vectors of L in WORK(IU) by
+* Q in A, storing result in VT
+* (Workspace: need M*M)
+*
+ CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
+ $ LDWRKU, A, LDA, ZERO, VT, LDVT )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to U, zeroing out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
+ $ LDU )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in U
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right bidiagonalizing vectors in U by Q
+* in VT
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
+ $ WORK( ITAUP ), VT, LDVT,
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in U
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
+ $ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ END IF
+*
+ ELSE IF( WNTVA ) THEN
+*
+ IF( WNTUN ) THEN
+*
+* Path 7t(N much larger than M, JOBU='N', JOBVT='A')
+* N right singular vectors to be computed in VT and
+* no left singular vectors to be computed
+*
+ IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+* WORK(IR) is LDA by M
+*
+ LDWRKR = LDA
+ ELSE
+*
+* WORK(IR) is M by M
+*
+ LDWRKR = M
+ END IF
+ ITAU = IR + LDWRKR*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Copy L to WORK(IR), zeroing out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ),
+ $ LDWRKR )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IR+LDWRKR ), LDWRKR )
+*
+* Generate Q in VT
+* (Workspace: need M*M+M+N, prefer M*M+M+N*NB)
+*
+ CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IR)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in WORK(IR)
+* (Workspace: need M*M+4*M-1,
+* prefer M*M+3*M+(M-1)*NB)
+*
+ CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of L in WORK(IR)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
+ $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply right singular vectors of L in WORK(IR) by
+* Q in VT, storing result in A
+* (Workspace: need M*M)
+*
+ CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ),
+ $ LDWRKR, VT, LDVT, ZERO, A, LDA )
+*
+* Copy right singular vectors of A from A to VT
+*
+ CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need M+N, prefer M+N*NB)
+*
+ CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Zero out above L in A
+*
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
+ $ LDA )
+*
+* Bidiagonalize L in A
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right bidiagonalizing vectors in A by Q
+* in VT
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT,
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT,
+ $ LDVT, DUM, 1, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTUO ) THEN
+*
+* Path 8t(N much larger than M, JOBU='O', JOBVT='A')
+* N right singular vectors to be computed in VT and
+* M left singular vectors to be overwritten on A
+*
+ IF( LWORK.GE.2*M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
+*
+* WORK(IU) is LDA by M and WORK(IR) is LDA by M
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*M
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
+*
+* WORK(IU) is LDA by M and WORK(IR) is M by M
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*M
+ LDWRKR = M
+ ELSE
+*
+* WORK(IU) is M by M and WORK(IR) is M by M
+*
+ LDWRKU = M
+ IR = IU + LDWRKU*M
+ LDWRKR = M
+ END IF
+ ITAU = IR + LDWRKR*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB)
+*
+ CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to WORK(IU), zeroing out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IU+LDWRKU ), LDWRKU )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IU), copying result to
+* WORK(IR)
+* (Workspace: need 2*M*M+4*M,
+* prefer 2*M*M+3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU,
+ $ WORK( IR ), LDWRKR )
+*
+* Generate right bidiagonalizing vectors in WORK(IU)
+* (Workspace: need 2*M*M+4*M-1,
+* prefer 2*M*M+3*M+(M-1)*NB)
+*
+ CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in WORK(IR)
+* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of L in WORK(IR) and computing
+* right singular vectors of L in WORK(IU)
+* (Workspace: need 2*M*M+BDSPAC)
+*
+ CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+ $ WORK( IU ), LDWRKU, WORK( IR ),
+ $ LDWRKR, DUM, 1, WORK( IWORK ), INFO )
+*
+* Multiply right singular vectors of L in WORK(IU) by
+* Q in VT, storing result in A
+* (Workspace: need M*M)
+*
+ CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
+ $ LDWRKU, VT, LDVT, ZERO, A, LDA )
+*
+* Copy right singular vectors of A from A to VT
+*
+ CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+* Copy left singular vectors of A from WORK(IR) to A
+*
+ CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
+ $ LDA )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need M+N, prefer M+N*NB)
+*
+ CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Zero out above L in A
+*
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
+ $ LDA )
+*
+* Bidiagonalize L in A
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right bidiagonalizing vectors in A by Q
+* in VT
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT,
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in A
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in A and computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
+ $ LDVT, A, LDA, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTUAS ) THEN
+*
+* Path 9t(N much larger than M, JOBU='S' or 'A',
+* JOBVT='A')
+* N right singular vectors to be computed in VT and
+* M left singular vectors to be computed in U
+*
+ IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+* WORK(IU) is LDA by M
+*
+ LDWRKU = LDA
+ ELSE
+*
+* WORK(IU) is M by M
+*
+ LDWRKU = M
+ END IF
+ ITAU = IU + LDWRKU*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need M*M+M+N, prefer M*M+M+N*NB)
+*
+ CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to WORK(IU), zeroing out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IU+LDWRKU ), LDWRKU )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IU), copying result to U
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
+ $ LDU )
+*
+* Generate right bidiagonalizing vectors in WORK(IU)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB)
+*
+ CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in U
+* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of L in U and computing right
+* singular vectors of L in WORK(IU)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+ $ WORK( IU ), LDWRKU, U, LDU, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply right singular vectors of L in WORK(IU) by
+* Q in VT, storing result in A
+* (Workspace: need M*M)
+*
+ CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
+ $ LDWRKU, VT, LDVT, ZERO, A, LDA )
+*
+* Copy right singular vectors of A from A to VT
+*
+ CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need M+N, prefer M+N*NB)
+*
+ CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to U, zeroing out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
+ $ LDU )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in U
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right bidiagonalizing vectors in U by Q
+* in VT
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
+ $ WORK( ITAUP ), VT, LDVT,
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in U
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
+ $ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ END IF
+*
+ END IF
+*
+ ELSE
+*
+* N .LT. MNTHR
+*
+* Path 10t(N greater than M, but not much larger)
+* Reduce to bidiagonal form without LQ decomposition
+*
+ IE = 1
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize A
+* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
+*
+ CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+ $ IERR )
+ IF( WNTUAS ) THEN
+*
+* If left singular vectors desired in U, copy result to U
+* and generate left bidiagonalizing vectors in U
+* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB)
+*
+ CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
+ CALL DORGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IF( WNTVAS ) THEN
+*
+* If right singular vectors desired in VT, copy result to
+* VT and generate right bidiagonalizing vectors in VT
+* (Workspace: need 3*M+NRVT, prefer 3*M+NRVT*NB)
+*
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+ IF( WNTVA )
+ $ NRVT = N
+ IF( WNTVS )
+ $ NRVT = M
+ CALL DORGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IF( WNTUO ) THEN
+*
+* If left singular vectors desired in A, generate left
+* bidiagonalizing vectors in A
+* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB)
+*
+ CALL DORGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IF( WNTVO ) THEN
+*
+* If right singular vectors desired in A, generate right
+* bidiagonalizing vectors in A
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IWORK = IE + M
+ IF( WNTUAS .OR. WNTUO )
+ $ NRU = M
+ IF( WNTUN )
+ $ NRU = 0
+ IF( WNTVAS .OR. WNTVO )
+ $ NCVT = N
+ IF( WNTVN )
+ $ NCVT = 0
+ IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
+*
+* Perform bidiagonal QR iteration, if desired, computing
+* left singular vectors in U and computing right singular
+* vectors in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT,
+ $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO )
+ ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
+*
+* Perform bidiagonal QR iteration, if desired, computing
+* left singular vectors in U and computing right singular
+* vectors in A
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), A, LDA,
+ $ U, LDU, DUM, 1, WORK( IWORK ), INFO )
+ ELSE
+*
+* Perform bidiagonal QR iteration, if desired, computing
+* left singular vectors in A and computing right singular
+* vectors in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT,
+ $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO )
+ END IF
+*
+ END IF
+*
+ END IF
+*
+* If DBDSQR failed to converge, copy unconverged superdiagonals
+* to WORK( 2:MINMN )
+*
+ IF( INFO.NE.0 ) THEN
+ IF( IE.GT.2 ) THEN
+ DO 50 I = 1, MINMN - 1
+ WORK( I+1 ) = WORK( I+IE-1 )
+ 50 CONTINUE
+ END IF
+ IF( IE.LT.2 ) THEN
+ DO 60 I = MINMN - 1, 1, -1
+ WORK( I+1 ) = WORK( I+IE-1 )
+ 60 CONTINUE
+ END IF
+ END IF
+*
+* Undo scaling if necessary
+*
+ IF( ISCL.EQ.1 ) THEN
+ IF( ANRM.GT.BIGNUM )
+ $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+ $ IERR )
+ IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM )
+ $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1, WORK( 2 ),
+ $ MINMN, IERR )
+ IF( ANRM.LT.SMLNUM )
+ $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+ $ IERR )
+ IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM )
+ $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1, WORK( 2 ),
+ $ MINMN, IERR )
+ END IF
+*
+* Return optimal workspace in WORK(1)
+*
+ WORK( 1 ) = MAXWRK
+*
+ RETURN
+*
+* End of DGESVD
+*
+ END
+
+\end{chunk}
+
+\begin{chunk}{LAPACK dgesvd}
+(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 (simple-array double-float (*)) work vt u s a)
+ (type fixnum info lwork ldvt ldu lda n m)
+ (type 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 (simple-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 (char-equal jobu #\A))
+ (setf wntus (char-equal jobu #\S))
+ (setf wntuas (or wntua wntus))
+ (setf wntuo (char-equal jobu #\O))
+ (setf wntun (char-equal jobu #\N))
+ (setf wntva (char-equal jobvt #\A))
+ (setf wntvs (char-equal jobvt #\S))
+ (setf wntvas (or wntva wntvs))
+ (setf wntvo (char-equal jobvt #\O))
+ (setf wntvn (char-equal 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))))))
+ 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))))))
+ (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
@@ -53306,38 +56645,38 @@ ARGUMENTS
(the fixnum
(f2cl-lib:int-add n
(f2cl-lib:int-mul m
- (ilaenv
- 1
- "DORGQR"
- " "
- m m
- n
- -1))))))
+ (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))))))
+ 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))))))
+ (ilaenv
+ 1
+ "DORGBR"
+ "Q"
+ n n
+ n
+ -1))))))
(setf wrkbl
(max (the fixnum wrkbl)
(the fixnum bdspac)))
@@ -53363,38 +56702,38 @@ ARGUMENTS
(the fixnum
(f2cl-lib:int-add n
(f2cl-lib:int-mul m
- (ilaenv
- 1
- "DORGQR"
- " "
- m m
- n
- -1))))))
+ (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))))))
+ 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))))))
+ (ilaenv
+ 1
+ "DORGBR"
+ "Q"
+ n n
+ n
+ -1))))))
(setf wrkbl
(max (the fixnum wrkbl)
(the fixnum
@@ -53428,38 +56767,38 @@ ARGUMENTS
(the fixnum
(f2cl-lib:int-add n
(f2cl-lib:int-mul m
- (ilaenv
- 1
- "DORGQR"
- " "
- m m
- n
- -1))))))
+ (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))))))
+ 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))))))
+ (ilaenv
+ 1
+ "DORGBR"
+ "Q"
+ n n
+ n
+ -1))))))
(setf wrkbl
(max (the fixnum wrkbl)
(the fixnum
@@ -53486,33 +56825,33 @@ ARGUMENTS
(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))))
+ (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)))))))
+ (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)))))))
+ (ilaenv
+ 1
+ "DORGBR"
+ "Q"
+ m m
+ n
+ -1)))))))
(if (not wntvn)
(setf maxwrk
(max (the fixnum maxwrk)
@@ -53551,14 +56890,14 @@ ARGUMENTS
(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))))))
+ m
+ (ilaenv
+ 1
+ "DGEBRD"
+ " "
+ m m
+ -1
+ -1))))))
(if (or wntuo wntuas)
(setf maxwrk
(max (the fixnum maxwrk)
@@ -53590,26 +56929,26 @@ ARGUMENTS
(the fixnum
(f2cl-lib:int-add m
(f2cl-lib:int-mul m
- (ilaenv
- 1
- "DORGLQ"
- " "
- m n
- m
- -1))))))
+ (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))))))
+ m
+ (ilaenv
+ 1
+ "DGEBRD"
+ " "
+ m m
+ -1
+ -1))))))
(setf wrkbl
(max (the fixnum wrkbl)
(the fixnum
@@ -53650,26 +56989,26 @@ ARGUMENTS
(the fixnum
(f2cl-lib:int-add m
(f2cl-lib:int-mul m
- (ilaenv
- 1
- "DORGLQ"
- " "
- m n
- m
- -1))))))
+ (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))))))
+ m
+ (ilaenv
+ 1
+ "DGEBRD"
+ " "
+ m m
+ -1
+ -1))))))
(setf wrkbl
(max (the fixnum wrkbl)
(the fixnum
@@ -53683,13 +57022,13 @@ ARGUMENTS
(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))))))
+ (ilaenv
+ 1
+ "DORGBR"
+ "Q"
+ m m
+ m
+ -1))))))
(setf wrkbl
(max (the fixnum wrkbl)
(the fixnum bdspac)))
@@ -53722,26 +57061,26 @@ ARGUMENTS
(the fixnum
(f2cl-lib:int-add m
(f2cl-lib:int-mul m
- (ilaenv
- 1
- "DORGLQ"
- " "
- m n
- m
- -1))))))
+ (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))))))
+ m
+ (ilaenv
+ 1
+ "DGEBRD"
+ " "
+ m m
+ -1
+ -1))))))
(setf wrkbl
(max (the fixnum wrkbl)
(the fixnum
@@ -53775,26 +57114,26 @@ ARGUMENTS
(the fixnum
(f2cl-lib:int-add m
(f2cl-lib:int-mul m
- (ilaenv
- 1
- "DORGLQ"
- " "
- m n
- m
- -1))))))
+ (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))))))
+ m
+ (ilaenv
+ 1
+ "DGEBRD"
+ " "
+ m m
+ -1
+ -1))))))
(setf wrkbl
(max (the fixnum wrkbl)
(the fixnum
@@ -53808,13 +57147,13 @@ ARGUMENTS
(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))))))
+ (ilaenv
+ 1
+ "DORGBR"
+ "Q"
+ m m
+ m
+ -1))))))
(setf wrkbl
(max (the fixnum wrkbl)
(the fixnum bdspac)))
@@ -53840,26 +57179,26 @@ ARGUMENTS
(the fixnum
(f2cl-lib:int-add m
(f2cl-lib:int-mul m
- (ilaenv
- 1
- "DORGLQ"
- " "
- m n
- m
- -1))))))
+ (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))))))
+ m
+ (ilaenv
+ 1
+ "DGEBRD"
+ " "
+ m m
+ -1
+ -1))))))
(setf wrkbl
(max (the fixnum wrkbl)
(the fixnum
@@ -53873,13 +57212,13 @@ ARGUMENTS
(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))))))
+ (ilaenv
+ 1
+ "DORGBR"
+ "Q"
+ m m
+ m
+ -1))))))
(setf wrkbl
(max (the fixnum wrkbl)
(the fixnum bdspac)))
@@ -53905,26 +57244,26 @@ ARGUMENTS
(the fixnum
(f2cl-lib:int-add m
(f2cl-lib:int-mul n
- (ilaenv
- 1
- "DORGLQ"
- " "
- n n
- m
- -1))))))
+ (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))))))
+ m
+ (ilaenv
+ 1
+ "DGEBRD"
+ " "
+ m m
+ -1
+ -1))))))
(setf wrkbl
(max (the fixnum wrkbl)
(the fixnum
@@ -53958,26 +57297,26 @@ ARGUMENTS
(the fixnum
(f2cl-lib:int-add m
(f2cl-lib:int-mul n
- (ilaenv
- 1
- "DORGLQ"
- " "
- n n
- m
- -1))))))
+ (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))))))
+ m
+ (ilaenv
+ 1
+ "DGEBRD"
+ " "
+ m m
+ -1
+ -1))))))
(setf wrkbl
(max (the fixnum wrkbl)
(the fixnum
@@ -53991,13 +57330,13 @@ ARGUMENTS
(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))))))
+ (ilaenv
+ 1
+ "DORGBR"
+ "Q"
+ m m
+ m
+ -1))))))
(setf wrkbl
(max (the fixnum wrkbl)
(the fixnum bdspac)))
@@ -54023,26 +57362,26 @@ ARGUMENTS
(the fixnum
(f2cl-lib:int-add m
(f2cl-lib:int-mul n
- (ilaenv
- 1
- "DORGLQ"
- " "
- n n
- m
- -1))))))
+ (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))))))
+ m
+ (ilaenv
+ 1
+ "DGEBRD"
+ " "
+ m m
+ -1
+ -1))))))
(setf wrkbl
(max (the fixnum wrkbl)
(the fixnum
@@ -54056,13 +57395,13 @@ ARGUMENTS
(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))))))
+ (ilaenv
+ 1
+ "DORGBR"
+ "Q"
+ m m
+ m
+ -1))))))
(setf wrkbl
(max (the fixnum wrkbl)
(the fixnum bdspac)))
@@ -54081,33 +57420,33 @@ ARGUMENTS
(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))))
+ (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)))))))
+ (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)))))))
+ (ilaenv
+ 1
+ "DORGBR"
+ "P"
+ n n
+ m
+ -1)))))))
(if (not wntun)
(setf maxwrk
(max (the fixnum maxwrk)
@@ -54145,7 +57484,7 @@ ARGUMENTS
(cond
((or (= m 0) (= n 0))
(if (>= lwork 1)
- (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) one))
+ (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))
@@ -54799,7 +58138,7 @@ ARGUMENTS
(setf ir 1)
(cond
((>= lwork
- (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda n)))
+ (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda n)))
(setf ldwrkr lda))
(t
(setf ldwrkr n)))
@@ -55384,7 +58723,7 @@ ARGUMENTS
(setf iu 1)
(cond
((>= lwork
- (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda n)))
+ (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda n)))
(setf ldwrku lda))
(t
(setf ldwrku n)))
@@ -55682,7 +59021,7 @@ ARGUMENTS
(setf ir 1)
(cond
((>= lwork
- (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda n)))
+ (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda n)))
(setf ldwrkr lda))
(t
(setf ldwrkr n)))
@@ -56275,7 +59614,7 @@ ARGUMENTS
(setf iu 1)
(cond
((>= lwork
- (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda n)))
+ (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda n)))
(setf ldwrku lda))
(t
(setf ldwrku n)))
@@ -57307,7 +60646,7 @@ ARGUMENTS
(setf ir 1)
(cond
((>= lwork
- (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda m)))
+ (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda m)))
(setf ldwrkr lda))
(t
(setf ldwrkr m)))
@@ -57891,7 +61230,7 @@ ARGUMENTS
(setf iu 1)
(cond
((>= lwork
- (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda m)))
+ (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda m)))
(setf ldwrku lda))
(t
(setf ldwrku m)))
@@ -58188,7 +61527,7 @@ ARGUMENTS
(setf ir 1)
(cond
((>= lwork
- (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda m)))
+ (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda m)))
(setf ldwrkr lda))
(t
(setf ldwrkr m)))
@@ -58780,7 +62119,7 @@ ARGUMENTS
(setf iu 1)
(cond
((>= lwork
- (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda m)))
+ (f2cl-lib:int-add wrkbl (f2cl-lib:int-mul lda m)))
(setf ldwrku lda))
(t
(setf ldwrku m)))
@@ -59345,7 +62684,7 @@ ARGUMENTS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgesv.f}
SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* -- LAPACK driver routine (version 3.0) --
@@ -59404,7 +62743,7 @@ ARGUMENTS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dgesv}
(defun dgesv (n nrhs a lda ipiv b ldb$ info)
@@ -59529,7 +62868,7 @@ ARGUMENTS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgetf2.f}
SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -59623,7 +62962,7 @@ ARGUMENTS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dgetf2}
(let* ((one 1.0) (zero 0.0))
@@ -59798,7 +63137,7 @@ ARGUMENTS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgetrf.f}
SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -59917,7 +63256,7 @@ ARGUMENTS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dgetrf}
(let* ((one 1.0))
@@ -60125,7 +63464,7 @@ ARGUMENTS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dgetrs.f}
SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -60231,7 +63570,7 @@ ARGUMENTS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dgetrs}
(let* ((one 1.0))
@@ -60251,7 +63590,8 @@ ARGUMENTS
(setf info 0)
(setf notran (char-equal trans #\N))
(cond
- ((and (not notran) (not (char-equal trans #\T)) (not (char-equal trans #\C)))
+ ((and (not notran) (not (char-equal trans #\T))
+ (not (char-equal trans #\C)))
(setf info -1))
((< n 0)
(setf info -2))
@@ -60426,7 +63766,7 @@ ARGUMENTS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dhseqr.f}
SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z,
$ LDZ, WORK, LWORK, INFO )
*
@@ -60798,7 +64138,7 @@ ARGUMENTS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dhseqr}
(let* ((zero 0.0) (one 1.0) (two 2.0) (const 1.5) (nsmax 15) (lds nsmax))
@@ -61321,7 +64661,7 @@ Online html documentation available at
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{disnan.f}
* =====================================================================
LOGICAL FUNCTION DISNAN( DIN )
@@ -61346,7 +64686,7 @@ Online html documentation available at
RETURN
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK disnan}
\end{chunk}
@@ -61410,7 +64750,7 @@ ARGUMENTS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlabad.f}
SUBROUTINE DLABAD( SMALL, LARGE )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -61443,7 +64783,7 @@ ARGUMENTS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlabad}
(defun dlabad (small large)
@@ -61605,7 +64945,7 @@ FURTHER DETAILS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlabrd.f}
SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
$ LDY )
*
@@ -61779,7 +65119,7 @@ FURTHER DETAILS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlabrd}
(let* ((zero 0.0) (one 1.0))
@@ -62384,7 +65724,7 @@ FURTHER DETAILS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlacon.f}
SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -62546,7 +65886,7 @@ FURTHER DETAILS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlacon}
(let* ((itmax 5) (zero 0.0) (one 1.0) (two 2.0))
@@ -62768,7 +66108,7 @@ ARGUMENTS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlacpy.f}
SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -62823,7 +66163,7 @@ ARGUMENTS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlacpy}
(defun dlacpy (uplo m n a lda b ldb$)
@@ -62939,7 +66279,7 @@ NAME
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dladiv.f}
SUBROUTINE DLADIV( A, B, C, D, P, Q )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -62979,7 +66319,7 @@ NAME
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dladiv}
(defun dladiv (a b c d p q)
@@ -63084,7 +66424,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlaed6.f}
SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -63328,7 +66668,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlaed6}
(let* ((maxit 20)
@@ -63734,7 +67074,7 @@ ARGUMENTS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlaexc.f}
SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK,
$ INFO )
*
@@ -64035,7 +67375,7 @@ ARGUMENTS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlaexc}
(let* ((zero 0.0) (one 1.0) (ten 10.0) (ldd 4) (ldx 2))
@@ -64633,7 +67973,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlahqr.f}
SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
$ ILOZ, IHIZ, Z, LDZ, INFO )
*
@@ -64988,7 +68328,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlahqr}
(let* ((zero 0.0) (one 1.0) (half 0.5) (dat1 0.75) (dat2 (- 0.4375)))
@@ -65775,7 +69115,7 @@ FURTHER DETAILS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlahrd.f}
SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -65896,7 +69236,7 @@ FURTHER DETAILS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlahrd}
(let* ((zero 0.0) (one 1.0))
@@ -66142,7 +69482,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlaisnan.f}
* =====================================================================
LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 )
*
@@ -66162,7 +69502,7 @@ Man Page Details
RETURN
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlaisnan}
\end{chunk}
@@ -66323,7 +69663,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlaln2.f}
SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B,
$ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO )
*
@@ -66743,7 +70083,7 @@ c CI( 2, 2 ) = -WI*D2
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlaln2}
(let* ((zero 0.0) (one 1.0) (two 2.0))
@@ -67516,7 +70856,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlamch.f}
DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -67611,7 +70951,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlamch}
(let* ((one 1.0) (zero 0.0))
@@ -67771,7 +71111,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlamc1.f}
************************************************************************
*
SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 )
@@ -67922,7 +71262,7 @@ Man Page Details
END
*
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlamc1}
(let ((lieee1 nil) (lbeta 0) (lrnd nil) (f2cl-lib:lt 0) (first$ nil))
@@ -68143,7 +71483,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlamc2.f}
************************************************************************
*
SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
@@ -68352,7 +71692,7 @@ Man Page Details
* End of DLAMC2
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlamc2}
(let ((lbeta 0)
@@ -68643,7 +71983,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlamc3.f}
************************************************************************
*
DOUBLE PRECISION FUNCTION DLAMC3( A, B )
@@ -68671,7 +72011,7 @@ Man Page Details
END
*
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlamc3}
(defun dlamc3 (a b)
@@ -68738,7 +72078,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlamc4.f}
************************************************************************
*
SUBROUTINE DLAMC4( EMIN, START, BASE )
@@ -68805,7 +72145,7 @@ Man Page Details
END
*
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlamc4}
(defun dlamc4 (emin start base)
@@ -68942,7 +72282,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlamc5.f}
************************************************************************
*
SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
@@ -69074,7 +72414,7 @@ Man Page Details
*
*
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlamc5}
(let* ((zero 0.0) (one 1.0))
@@ -69220,7 +72560,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlamrg.f}
SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDX )
*
* -- LAPACK routine (version 3.0) --
@@ -69294,7 +72634,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlamrg}
(defun dlamrg (n1 n2 a dtrd1 dtrd2 indx)
@@ -69442,7 +72782,7 @@ ARGUMENTS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlange.f}
DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -69539,7 +72879,7 @@ ARGUMENTS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlange}
(let* ((one 1.0) (zero 0.0))
@@ -69728,7 +73068,7 @@ ARGUMENTS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlanhs.f}
DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -69825,7 +73165,7 @@ ARGUMENTS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlanhs}
(let* ((one 1.0) (zero 0.0))
@@ -70023,7 +73363,7 @@ ARGUMENTS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlanst.f}
DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -70108,7 +73448,7 @@ ARGUMENTS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlanst}
(let* ((one 1.0) (zero 0.0))
@@ -70141,7 +73481,8 @@ ARGUMENTS
(max anorm
(abs
(f2cl-lib:fref e-%data% (i) ((1 *)) e-%offset%)))))))
- ((or (char-equal norm #\O) (f2cl-lib:fstring-= norm "1") (char-equal norm #\I))
+ ((or (char-equal norm #\O) (f2cl-lib:fstring-= norm "1")
+ (char-equal norm #\I))
(cond
((= n 1)
(setf anorm
@@ -70283,7 +73624,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlanv2.f}
SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )
*
* -- LAPACK driver routine (version 3.0) --
@@ -70447,7 +73788,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlanv2}
(let* ((zero 0.0) (half 0.5) (one 1.0) (multpl 4.0))
@@ -70609,7 +73950,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlapy2.f}
DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -70652,7 +73993,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlapy2}
(let* ((zero 0.0) (one 1.0))
@@ -70742,7 +74083,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlapy3.f}
* =====================================================================
DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
*
@@ -70788,9 +74129,22 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlapy3}
+(let* ((zero 0.0d0))
+ (declare (type (double-float 0.0d0 0.0d0) zero) (ignorable zero))
+ (defun dlapy3 (x y z) (declare (type (double-float) z y x))
+ (prog ((w 0.0d0) (xabs 0.0d0) (yabs 0.0d0) (zabs 0.0d0) (dlapy3 0.0d0))
+ (declare (type (double-float) dlapy3 zabs yabs xabs w)) (setf xabs (abs x))
+ (setf yabs (abs y)) (setf zabs (abs z)) (setf w (max xabs yabs zabs))
+ (cond ((= w zero) (setf dlapy3 (+ xabs yabs zabs)))
+ (t
+ (setf dlapy3
+ (* w
+ (f2cl-lib:fsqrt
+ (+ (expt (/ xabs w) 2) (expt (/ yabs w) 2) (expt (/ zabs w) 2)))))))
+ (go end_label) end_label (return (values dlapy3 nil nil nil)))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{dlaqtr LAPACK}
@@ -70917,7 +74271,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlaqtr.f}
SUBROUTINE DLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK,
$ INFO )
*
@@ -71503,7 +74857,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlaqtr}
(let* ((zero 0.0) (one 1.0))
@@ -72756,7 +76110,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlarfb.f}
SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
*
@@ -73274,7 +76628,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlarfb}
(let* ((one 1.0))
@@ -73958,7 +77312,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlarfg.f}
SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -74054,7 +77408,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlarfg}
(let* ((one 1.0) (zero 0.0))
@@ -74198,7 +77552,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlarf.f}
SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -74267,7 +77621,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlarf}
(let* ((one 1.0) (zero 0.0))
@@ -74427,7 +77781,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlarft.f}
SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -74559,7 +77913,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlarft}
(let* ((one 1.0) (zero 0.0))
@@ -74882,7 +78236,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlarfx.f}
SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -75475,7 +78829,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlarfx}
(let* ((zero 0.0) (one 1.0))
@@ -77593,7 +80947,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlartg.f}
SUBROUTINE DLARTG( F, G, CS, SN, R )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -77702,7 +81056,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlartg}
(let* ((zero 0.0) (one 1.0) (two 2.0))
@@ -77863,7 +81217,7 @@ FURTHER DETAILS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlas2.f}
SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -77941,7 +81295,7 @@ FURTHER DETAILS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlas2}
(let* ((zero 0.0) (one 1.0) (two 2.0))
@@ -78100,7 +81454,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlascl.f}
SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -78311,7 +81665,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlascl}
(let* ((zero 0.0) (one 1.0))
@@ -78684,7 +82038,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasd0.f}
SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK,
$ WORK, INFO )
*
@@ -78850,7 +82204,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasd0}
(defun dlasd0 (n sqre d e u ldu vt ldvt smlsiz iwork work info)
@@ -79239,7 +82593,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasd1.f}
SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT,
$ IDXQ, IWORK, WORK, INFO )
*
@@ -79361,7 +82715,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasd1}
(let* ((one 1.0) (zero 0.0))
@@ -79692,7 +83046,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasd2.f}
SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT,
$ LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX,
$ IDXC, IDXQ, COLTYP, INFO )
@@ -80061,7 +83415,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasd2}
(let* ((zero 0.0) (one 1.0) (two 2.0) (eight 8.0))
@@ -80698,7 +84052,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasd3.f}
SUBROUTINE DLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2,
$ LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z,
$ INFO )
@@ -80947,7 +84301,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasd3}
(let* ((one 1.0) (zero 0.0) (negone (- 1.0)))
@@ -81569,7 +84923,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasd4.f}
SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -82384,7 +85738,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasd4}
(let* ((maxit 20)
@@ -84002,7 +87356,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasd5.f}
SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -84119,7 +87473,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasd5}
(let* ((zero 0.0) (one 1.0) (two 2.0) (three 3.0) (four 4.0))
@@ -84552,7 +87906,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasd6.f}
SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA,
$ IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM,
$ LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK,
@@ -84681,7 +88035,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasd6}
(let* ((one 1.0) (zero 0.0))
@@ -84692,8 +88046,8 @@ SYNOPSIS
givnum ldgnum poles difl difr z k c s work iwork info)
(declare (type (simple-array fixnum (*)) iwork givcol perm idxq)
(type (double-float) s c beta alpha)
- (type (simple-array double-float (*)) work z difr difl poles givnum vl vf
- d)
+ (type (simple-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
@@ -85031,7 +88385,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasd7.f}
SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL,
$ VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ,
$ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
@@ -85336,7 +88690,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasd7}
(let* ((zero 0.0) (one 1.0) (two 2.0) (eight 8.0))
@@ -85349,7 +88703,8 @@ SYNOPSIS
idxq perm givptr givcol ldgcol givnum ldgnum c s info)
(declare (type (simple-array fixnum (*)) givcol perm idxq idxp idx)
(type (double-float) s c beta alpha)
- (type (simple-array double-float (*)) givnum dsigma vlw vl vfw vf zw z d)
+ (type (simple-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
@@ -85825,7 +89180,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasd8.f}
SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR,
$ DSIGMA, WORK, INFO )
*
@@ -86003,7 +89358,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasd8}
(let* ((one 1.0))
@@ -86540,7 +89895,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasda.f}
SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K,
$ DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL,
$ PERM, GIVNUM, C, S, WORK, IWORK, INFO )
@@ -86785,7 +90140,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasda}
(let* ((zero 0.0) (one 1.0))
@@ -87465,7 +90820,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasdq.f}
SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT,
$ U, LDU, C, LDC, WORK, INFO )
*
@@ -87670,7 +91025,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasdq}
(let* ((zero 0.0))
@@ -88024,7 +91379,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasdt.f}
SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -88093,7 +91448,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasdt}
(let* ((two 2.0))
@@ -88285,7 +91640,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlaset.f}
SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -88361,7 +91716,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlaset}
(defun dlaset (uplo m n alpha beta a lda)
@@ -88511,7 +91866,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasq1.f}
SUBROUTINE DLASQ1( N, D, E, WORK, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -88618,7 +91973,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasq1}
(let* ((zero 0.0))
@@ -88826,7 +92181,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasq2.f}
SUBROUTINE DLASQ2( N, Z, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -89212,7 +92567,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasq2}
(let* ((cbias 1.5)
@@ -89957,9 +93312,9 @@ SYNOPSIS
(f2cl-lib:int-add i4 4))
((> i4
(f2cl-lib:int-mul 4
- (f2cl-lib:int-add n0
- (f2cl-lib:int-sub
- 3))))
+ (f2cl-lib:int-add n0
+ (f2cl-lib:int-sub
+ 3))))
nil)
(tagbody
(cond
@@ -89967,14 +93322,14 @@ SYNOPSIS
(<= (f2cl-lib:fref z (i4) ((1 *)))
(* tol2
(f2cl-lib:fref z
- ((f2cl-lib:int-add i4
- (f2cl-lib:int-sub
+ ((f2cl-lib:int-add i4
+ (f2cl-lib:int-sub
3)))
((1 *)))))
(<=
(f2cl-lib:fref z
((f2cl-lib:int-add i4
- (f2cl-lib:int-sub
+ (f2cl-lib:int-sub
1)))
((1 *)))
(* tol2 sigma)))
@@ -90176,7 +93531,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasq3.f}
SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
$ ITER, NDIV, IEEE )
*
@@ -90427,7 +93782,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasq3}
(let* ((cbias 1.5)
@@ -90707,8 +94062,8 @@ SYNOPSIS
((> j4
(f2cl-lib:int-mul 2
(f2cl-lib:int-add i0
- n0
- (f2cl-lib:int-sub
+ n0
+ (f2cl-lib:int-sub
1))))
nil)
(tagbody
@@ -90951,9 +94306,9 @@ SYNOPSIS
(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-add n0
+ (f2cl-lib:int-sub
+ 1)))
(f2cl-lib:int-sub pp)))
((1 *)))
(* tol (+ sigma dn1)))
@@ -91121,7 +94476,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasq4.f}
SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN,
$ DN1, DN2, TAU, TTYPE )
*
@@ -91404,7 +94759,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasq4}
(let* ((cnst1 0.563)
@@ -92015,7 +95370,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasq5.f}
SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
$ DNM1, DNM2, IEEE )
*
@@ -92167,7 +95522,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasq5}
(let* ((zero 0.0))
@@ -92199,11 +95554,11 @@ SYNOPSIS
(ieee
(cond
((= pp 0)
- (f2cl-lib:fdo (j4 (f2cl-lib:int-mul 4 i0) (f2cl-lib:int-add j4 4))
+ (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
+ (f2cl-lib:int-sub
3))))
nil)
(tagbody
@@ -92239,11 +95594,11 @@ SYNOPSIS
(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))
+ (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
+ (f2cl-lib:int-sub
3))))
nil)
(tagbody
@@ -92357,11 +95712,11 @@ SYNOPSIS
(t
(cond
((= pp 0)
- (f2cl-lib:fdo (j4 (f2cl-lib:int-mul 4 i0) (f2cl-lib:int-add j4 4))
+ (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
+ (f2cl-lib:int-sub
3))))
nil)
(tagbody
@@ -92414,11 +95769,11 @@ SYNOPSIS
((1 *))
z-%offset%))))))
(t
- (f2cl-lib:fdo (j4 (f2cl-lib:int-mul 4 i0) (f2cl-lib:int-add j4 4))
+ (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
+ (f2cl-lib:int-add n0
+ (f2cl-lib:int-sub
3))))
nil)
(tagbody
@@ -92657,7 +96012,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasq6.f}
SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN,
$ DNM1, DNM2 )
*
@@ -92795,7 +96150,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasq6}
(let* ((zero 0.0))
@@ -93302,7 +96657,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasr.f}
SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -93541,7 +96896,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasr}
(let* ((one 1.0) (zero 0.0))
@@ -93565,7 +96920,8 @@ SYNOPSIS
(cond
((not (or (char-equal side #\L) (char-equal side #\R)))
(setf info 1))
- ((not (or (char-equal pivot #\V) (char-equal pivot #\T) (char-equal pivot #\B)))
+ ((not (or (char-equal pivot #\V) (char-equal pivot #\T)
+ (char-equal pivot #\B)))
(setf info 2))
((not (or (char-equal direct #\F) (char-equal direct #\B)))
(setf info 3))
@@ -94168,7 +97524,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasrt.f}
SUBROUTINE DLASRT( ID, N, D, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -94385,7 +97741,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasrt}
(let* ((select 20))
@@ -94687,7 +98043,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlassq.f}
SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -94737,7 +98093,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlassq}
(let* ((zero 0.0))
@@ -94874,7 +98230,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasv2.f}
SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -95063,7 +98419,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasv2}
(let* ((zero 0.0) (half 0.5) (one 1.0) (two 2.0) (four 4.0))
@@ -95277,7 +98633,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlaswp.f}
SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -95356,7 +98712,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlaswp}
(defun dlaswp (n a lda k1 k2 ipiv incx)
@@ -95580,7 +98936,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dlasy2.f}
SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR,
$ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )
*
@@ -95889,7 +99245,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dlasy2}
(let* ((zero 0.0) (one 1.0) (two 2.0) (half 0.5) (eight 8.0))
@@ -96660,7 +100016,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dorg2r.f}
SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -96748,7 +100104,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dorg2r}
(let* ((one 1.0) (zero 0.0))
@@ -96946,7 +100302,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dorgbr.f}
SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -97113,7 +100469,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dorgbr}
(let* ((zero 0.0) (one 1.0))
@@ -97392,7 +100748,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dorghr.f}
SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -97508,7 +100864,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dorghr}
(let* ((zero 0.0) (one 1.0))
@@ -97707,7 +101063,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dorgl2.f}
SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -97800,7 +101156,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dorgl2}
(let* ((one 1.0) (zero 0.0))
@@ -97982,7 +101338,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dorglq.f}
SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -98146,7 +101502,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dorglq}
(let* ((zero 0.0))
@@ -98401,7 +101757,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dorgqr.f}
SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.0) --
@@ -98565,7 +101921,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dorgqr}
(let* ((zero 0.0))
@@ -98845,7 +102201,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dorm2r.f}
SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
@@ -98971,7 +102327,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dorm2r}
(let* ((one 1.0))
@@ -99209,7 +102565,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dormbr.f}
SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
$ LDC, WORK, LWORK, INFO )
*
@@ -99389,7 +102745,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dormbr}
(defun dormbr (vect side trans m n k a lda tau c ldc work lwork info)
@@ -99691,7 +103047,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dorml2.f}
SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
@@ -99817,7 +103173,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dorml2}
(let* ((one 1.0))
@@ -100033,7 +103389,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dormlq.f}
SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
@@ -100221,7 +103577,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dormlq}
(let* ((nbmax 64) (ldt (+ nbmax 1)))
@@ -100510,7 +103866,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dormqr.f}
SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
*
@@ -100691,7 +104047,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dormqr}
(let* ((nbmax 64) (ldt (+ nbmax 1)))
@@ -101041,7 +104397,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dtrevc.f}
SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
$ LDVR, MM, M, WORK, INFO )
*
@@ -101899,7 +105255,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dtrevc}
(let* ((zero 0.0) (one 1.0))
@@ -103953,7 +107309,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dtrexc.f}
SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK,
$ INFO )
*
@@ -104236,7 +107592,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dtrexc}
(let* ((zero 0.0))
@@ -104768,7 +108124,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{dtrsna.f}
SUBROUTINE DTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
$ LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK,
$ INFO )
@@ -105109,7 +108465,7 @@ SYNOPSIS
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK dtrsna}
(let* ((zero 0.0) (one 1.0) (two 2.0))
@@ -105787,7 +109143,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{ieeeck.f}
INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE )
*
* -- LAPACK auxiliary routine (version 3.0) --
@@ -105908,7 +109264,7 @@ SYNOPSIS
RETURN
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK ieeeck}
(defun ieeeck (ispec zero one)
@@ -106121,7 +109477,7 @@ SYNOPSIS
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{ilaenv.f}
INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,
$ N4 )
*
@@ -106582,7 +109938,7 @@ C ILAENV = 0
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK ilaenv}
(defun ilaenv (ispec name opts n1 n2 n3 n4)
@@ -107107,7 +110463,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{ilazlc.f}
* =====================================================================
INTEGER FUNCTION ILAZLC( M, N, A, LDA )
*
@@ -107150,10 +110506,38 @@ Man Page Details
RETURN
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK ilazlc}
-
+(let* ((zero (coerce (f2cl-lib:cmplx 0.0d0 0.0d0) 'f2cl-lib:complex16)))
+ (declare (type (f2cl-lib:complex16) zero) (ignorable zero))
+ (defun ilazlc (m n a lda)
+ (declare (type (f2cl-lib:integer4) lda n m)
+ (type (array f2cl-lib:complex16 (*)) a))
+ (f2cl-lib:with-multi-array-data
+ ((a f2cl-lib:complex16 a-%data% a-%offset%))
+ (prog
+ ((i 0) (ilazlc 0)) (declare (type (f2cl-lib:integer4) ilazlc i))
+ (cond ((= n 0) (setf ilazlc n))
+ ((or (/= (f2cl-lib:fref a (1 n) ((1 lda) (1 *))) zero)
+ (/= (f2cl-lib:fref a (m n) ((1 lda) (1 *))) zero))
+ (setf ilazlc n))
+ (t
+ (f2cl-lib:fdo (ilazlc n (f2cl-lib:int-add ilazlc (f2cl-lib:int-sub 1)))
+ ((>
+ ilazlc 1)
+ nil)
+ (tagbody
+ (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
+ ((> i m) nil)
+ (tagbody
+ (if
+ (/= (f2cl-lib:fref a-%data% (i ilazlc)
+ ((1 lda) (1 *)) a-%offset%) zero)
+ (go end_label))
+ label100001))
+ label100000))))
+ (go end_label) end_label (return (values ilazlc nil nil nil nil))))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -107236,7 +110620,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{ilazlr.f}
* =====================================================================
INTEGER FUNCTION ILAZLR( M, N, A, LDA )
*
@@ -107285,9 +110669,42 @@ Man Page Details
RETURN
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK ilazlr}
+(let* ((zero (coerce (f2cl-lib:cmplx 0.0d0 0.0d0) 'f2cl-lib:complex16)))
+ (declare (type (f2cl-lib:complex16) zero) (ignorable zero))
+ (defun ilazlr (m n a lda)
+ (declare (type (f2cl-lib:integer4) lda n m)
+ (type (array f2cl-lib:complex16 (*)) a))
+ (f2cl-lib:with-multi-array-data
+ ((a f2cl-lib:complex16 a-%data% a-%offset%))
+ (prog
+ ((i 0) (j 0) (ilazlr 0))
+ (declare (type (f2cl-lib:integer4) ilazlr j i))
+ (cond ((= m 0) (setf ilazlr m))
+ ((or (/= (f2cl-lib:fref a (m 1) ((1 lda) (1 *))) zero)
+ (/= (f2cl-lib:fref a (m n) ((1 lda) (1 *))) zero))
+ (setf ilazlr m))
+ (t (setf ilazlr 0)
+ (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
+ ((> j n) nil)
+ (tagbody (setf i m)
+ label100001
+ (if
+ (not
+ (and (/= (f2cl-lib:fref a-%data% (i j)
+ ((1 lda) (1 *)) a-%offset%) zero)
+ (>= i 1)))
+ (go label100002))
+ (setf i (f2cl-lib:int-sub i 1))
+ (cond ((= i 0) (go f2cl-lib::exit)))
+ (go label100001) label100002
+ (setf ilazlr
+ (max (the f2cl-lib:integer4 ilazlr)
+ (the f2cl-lib:integer4 i)))
+ label100000))))
+ (go end_label) end_label (return (values ilazlr nil nil nil nil))))))}
\end{chunk}
@@ -107420,7 +110837,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zgebak.f}
* =====================================================================
SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
$ INFO )
@@ -107563,10 +110980,177 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zgebak}
-
+(let* ((one 1.0d0))
+ (declare (type (double-float 1.0d0 1.0d0) one) (ignorable one))
+ (defun zgebak (job side n ilo ihi scale m v ldv info)
+ (declare (type (simple-array character (*)) side job)
+ (type (f2cl-lib:integer4) info ldv m ihi ilo n)
+ (type (array double-float (*)) scale)
+ (type (array f2cl-lib:complex16 (*)) v))
+ (f2cl-lib:with-multi-array-data
+ ((v f2cl-lib:complex16 v-%data% v-%offset%)
+ (scale double-float scale-%data% scale-%offset%)
+ (job character job-%data% job-%offset%)
+ (side character side-%data% side-%offset%))
+ (prog
+ ((s 0.0d0) (i 0) (ii 0) (k 0) (leftv nil) (rightv nil))
+ (declare (type (double-float) s) (type (f2cl-lib:integer4) k ii i)
+ (type f2cl-lib:logical rightv leftv))
+ (setf rightv
+ (multiple-value-bind (ret-val var-0 var-1) (lsame side "R")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val))
+ (setf leftv
+ (multiple-value-bind (ret-val var-0 var-1) (lsame side "L")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val))
+ (setf info 0)
+ (cond
+ ((and
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame job "N")
+ (declare (ignore var-1)) (when var-0 (setf job var-0)) ret-val))
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame job "P")
+ (declare (ignore var-1)) (when var-0 (setf job var-0)) ret-val))
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame job "S")
+ (declare (ignore var-1)) (when var-0 (setf job var-0)) ret-val))
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame job "B")
+ (declare (ignore var-1)) (when var-0 (setf job var-0)) ret-val)))
+ (setf info -1))
+ ((and (not rightv) (not leftv))
+ (setf info -2)) ((< n 0) (setf info -3))
+ ((or (< ilo 1)
+ (> ilo (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n))))
+ (setf info -4))
+ ((or (< ihi (min (the f2cl-lib:integer4 ilo)
+ (the f2cl-lib:integer4 n)))
+ (> ihi n))
+ (setf info -5))
+ ((< m 0) (setf info -7))
+ ((< ldv (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n)))
+ (setf info -9)))
+ (cond ((/= info 0)
+ (xerbla "ZGEBAK" (f2cl-lib:int-sub info)) (go end_label)))
+ (if (= n 0) (go end_label)) (if (= m 0) (go end_label))
+ (if
+ (multiple-value-bind (ret-val var-0 var-1) (lsame job "N")
+ (declare (ignore var-1)) (when var-0 (setf job var-0)) ret-val)
+ (go end_label))
+ (if (= ilo ihi) (go label30))
+ (cond
+ ((or
+ (multiple-value-bind (ret-val var-0 var-1) (lsame job "S")
+ (declare (ignore var-1)) (when var-0 (setf job var-0)) ret-val)
+ (multiple-value-bind (ret-val var-0 var-1) (lsame job "B")
+ (declare (ignore var-1)) (when var-0 (setf job var-0)) ret-val))
+ (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%))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zdscal m s
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ (i 1) ((1 ldv) (1 *))
+ v-%offset%)
+ ldv)
+ (declare (ignore var-2))
+ (when var-0 (setf m var-0))
+ (when var-1 (setf s var-1))
+ (when var-3 (setf ldv var-3)))
+ label10))))
+ (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%)))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zdscal m s
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ (i 1) ((1 ldv) (1 *))
+ v-%offset%)
+ ldv)
+ (declare (ignore var-2))
+ (when var-0 (setf m var-0))
+ (when var-1 (setf s var-1))
+ (when var-3 (setf ldv var-3)))
+ label20))))))
+ label30
+ (cond
+ ((or
+ (multiple-value-bind (ret-val var-0 var-1) (lsame job "P")
+ (declare (ignore var-1)) (when var-0 (setf job var-0)) ret-val)
+ (multiple-value-bind (ret-val var-0 var-1) (lsame job "B")
+ (declare (ignore var-1)) (when var-0 (setf job var-0)) ret-val))
+ (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))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
+ (zswap m
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ (i 1) ((1 ldv) (1 *))
+ v-%offset%)
+ ldv
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ (k 1) ((1 ldv) (1 *))
+ v-%offset%)
+ ldv)
+ (declare (ignore var-1 var-3))
+ (when var-0 (setf m var-0))
+ (when var-2 (setf ldv var-2))
+ (when var-4 (setf ldv var-4)))
+ 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))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
+ (zswap m
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ (i 1) ((1 ldv) (1 *))
+ v-%offset%)
+ ldv
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ (k 1) ((1 ldv) (1 *))
+ v-%offset%)
+ ldv)
+ (declare (ignore var-1 var-3))
+ (when var-0 (setf m var-0))
+ (when var-2 (setf ldv var-2))
+ (when var-4 (setf ldv var-4)))
+ label50))))))
+ (go end_label) end_label
+ (return (values job side nil nil nil nil m nil ldv info))))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -107725,7 +111309,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zgebal.f}
* =====================================================================
SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
*
@@ -107981,10 +111565,284 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zgebal}
-
+(let* ((zero 0.0d0) (one 1.0d0) (sclfac 2.0d0) (factor 0.95d0))
+ (declare (type (double-float 0.0d0 0.0d0) zero)
+ (type (double-float 1.0d0 1.0d0) one)
+ (type (double-float 2.0d0 2.0d0) sclfac)
+ (type (double-float 0.95d0 0.95d0) factor)
+ (ignorable zero one sclfac factor))
+ (defun zgebal (job n a lda ilo ihi scale info)
+ (declare (type (simple-array character (*)) job)
+ (type (f2cl-lib:integer4) info ihi ilo lda n)
+ (type (array f2cl-lib:complex16 (*)) a)
+ (type (array double-float (*)) scale))
+ (f2cl-lib:with-multi-array-data
+ ((scale double-float scale-%data%
+ scale-%offset%)
+ (a f2cl-lib:complex16 a-%data% a-%offset%)
+ (job character job-%data% job-%offset%))
+ (labels
+ ((cabs1 (cdum)
+ (+ (abs (f2cl-lib:dble cdum)) (abs (f2cl-lib:dimag cdum)))))
+ (declare
+ (ftype (function (f2cl-lib:complex16)
+ (values double-float &rest t)) cabs1))
+ (prog
+ ((cdum #C(0.0d0 0.0d0)) (c 0.0d0) (ca 0.0d0) (f 0.0d0)
+ (g 0.0d0) (r 0.0d0)
+ (ra 0.0d0) (s 0.0d0) (sfmax1 0.0d0) (sfmax2 0.0d0) (sfmin1 0.0d0)
+ (sfmin2 0.0d0) (i 0) (ica 0) (iexc 0) (ira 0) (j 0) (k 0) (l 0) (m 0)
+ (noconv nil))
+ (declare (type (f2cl-lib:complex16) cdum)
+ (type (double-float) sfmin2 sfmin1 sfmax2 sfmax1 s ra r g f ca c)
+ (type (f2cl-lib:integer4) m l k j ira iexc ica i)
+ (type f2cl-lib:logical noconv))
+ (setf info 0)
+ (cond
+ ((and
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame job "N")
+ (declare (ignore var-1)) (when var-0 (setf job var-0)) ret-val))
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame job "P")
+ (declare (ignore var-1)) (when var-0 (setf job var-0)) ret-val))
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame job "S")
+ (declare (ignore var-1)) (when var-0 (setf job var-0)) ret-val))
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame job "B")
+ (declare (ignore var-1)) (when var-0 (setf job var-0)) ret-val)))
+ (setf info -1))
+ ((< n 0) (setf info -2))
+ ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n)))
+ (setf info -4)))
+ (cond ((/= info 0)
+ (xerbla "ZGEBAL" (f2cl-lib:int-sub info))
+ (go end_label)))
+ (setf k 1) (setf l n) (if (= n 0) (go label210))
+ (cond
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame job "N")
+ (declare (ignore var-1)) (when var-0 (setf job var-0)) ret-val)
+ (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)
+ label10))
+ (go label210)))
+ (if
+ (multiple-value-bind (ret-val var-0 var-1) (lsame job "S")
+ (declare (ignore var-1)) (when var-0 (setf job var-0)) ret-val)
+ (go label120))
+ (go label50) label20
+ (setf (f2cl-lib:fref scale-%data% (m) ((1 *)) scale-%offset%)
+ (coerce (the f2cl-lib:integer4 j) 'double-float))
+ (if (= j m) (go label30))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
+ (zswap l
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ (1 j) ((1 lda) (1 *))
+ a-%offset%)
+ 1
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ (1 m) ((1 lda) (1 *))
+ a-%offset%)
+ 1)
+ (declare (ignore var-1 var-2 var-3 var-4))
+ (when var-0 (setf l var-0)))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
+ (zswap (f2cl-lib:int-add (f2cl-lib:int-sub n k) 1)
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ (j k) ((1 lda) (1 *))
+ a-%offset%)
+ lda
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ (m k) ((1 lda) (1 *))
+ a-%offset%)
+ lda)
+ (declare (ignore var-0 var-1 var-3)) (when var-2 (setf lda var-2))
+ (when var-4 (setf lda var-4)))
+ 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
+ (or
+ (/=
+ (f2cl-lib:dble
+ (f2cl-lib:fref a-%data% (j i) ((1 lda) (1 *))
+ a-%offset%))
+ zero)
+ (/=
+ (f2cl-lib:dimag
+ (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
+ (or
+ (/=
+ (f2cl-lib:dble
+ (f2cl-lib:fref a-%data% (i j) ((1 lda) (1 *))
+ a-%offset%))
+ zero)
+ (/=
+ (f2cl-lib:dimag
+ (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) label130)
+ )
+ (if
+ (multiple-value-bind (ret-val var-0 var-1) (lsame job "P")
+ (declare (ignore var-1)) (when var-0 (setf job var-0)) ret-val)
+ (go label210))
+ (setf sfmin1 (/ (dlamch "S") (dlamch "P")))
+ (setf sfmax1 (/ one sfmin1))
+ (setf sfmin2 (* sfmin1 sclfac)) (setf sfmax2 (/ one sfmin2)) label140
+ (setf noconv f2cl-lib:%false%)
+ (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
+ (cabs1
+ (f2cl-lib:fref a-%data% (j i) ((1 lda) (1 *))
+ a-%offset%))))
+ (setf r
+ (+ r
+ (cabs1
+ (f2cl-lib:fref a-%data% (i j) ((1 lda) (1 *))
+ a-%offset%))))
+ label150))
+ (setf ica
+ (multiple-value-bind (ret-val var-0 var-1 var-2)
+ (izamax l
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ (1 i) ((1 lda) (1 *))
+ a-%offset%)
+ 1)
+ (declare (ignore var-1 var-2))
+ (when var-0 (setf l var-0)) ret-val))
+ (setf ca
+ (abs
+ (f2cl-lib:fref a-%data% (ica i) ((1 lda) (1 *))
+ a-%offset%)))
+ (setf ira
+ (multiple-value-bind (ret-val var-0 var-1 var-2)
+ (izamax (f2cl-lib:int-add (f2cl-lib:int-sub n k) 1)
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ (i k) ((1 lda) (1 *))
+ a-%offset%)
+ lda)
+ (declare (ignore var-0 var-1))
+ (when var-2 (setf lda var-2)) ret-val))
+ (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))
+ (cond
+ ((disnan (+ c f ca r g ra)) (setf info -3)
+ (xerbla "ZGEBAL" (f2cl-lib:int-sub info))
+ (go end_label)))
+ (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 f2cl-lib:%true%)
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zdscal (f2cl-lib:int-add (f2cl-lib:int-sub n k) 1) g
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ (i k) ((1 lda) (1 *))
+ a-%offset%)
+ lda)
+ (declare (ignore var-0 var-2)) (when var-1 (setf g var-1))
+ (when var-3 (setf lda var-3)))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zdscal l f
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ (1 i) ((1 lda) (1 *))
+ a-%offset%)
+ 1)
+ (declare (ignore var-2 var-3)) (when var-0 (setf l var-0))
+ (when var-1 (setf f var-1)))
+ label200))
+ (if noconv (go label140)) label210
+ (setf ilo k) (setf ihi l) (go end_label)
+ end_label (return (values job nil nil lda ilo ihi nil info)))))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -108161,7 +112019,7 @@ eigenvectors for GE matrices
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zgeev.f}
* =====================================================================
SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR,
$ WORK, LWORK, RWORK, INFO )
@@ -108477,10 +112335,511 @@ eigenvectors for GE matrices
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zgeev}
-
+(let* ((zero 0.0d0) (one 1.0d0))
+ (declare (type (double-float 0.0d0 0.0d0) zero)
+ (type (double-float 1.0d0 1.0d0) one) (ignorable zero one))
+ (defun zgeev (jobvl jobvr n a lda w vl ldvl vr ldvr work lwork rwork info)
+ (declare (type (simple-array character (*)) jobvr jobvl)
+ (type (f2cl-lib:integer4) info lwork ldvr ldvl lda n)
+ (type (array f2cl-lib:complex16 (*)) work vr vl w a)
+ (type (array double-float (*)) rwork))
+ (f2cl-lib:with-multi-array-data
+ ((rwork double-float rwork-%data%
+ rwork-%offset%)
+ (a f2cl-lib:complex16 a-%data% a-%offset%)
+ (w f2cl-lib:complex16 w-%data% w-%offset%)
+ (vl f2cl-lib:complex16 vl-%data% vl-%offset%)
+ (vr f2cl-lib:complex16 vr-%data% vr-%offset%)
+ (work f2cl-lib:complex16 work-%data% work-%offset%)
+ (jobvl character jobvl-%data% jobvl-%offset%)
+ (jobvr character jobvr-%data% jobvr-%offset%))
+ (prog
+ ((dum (make-array 1 :element-type 'double-float))
+ (select (make-array 1 :element-type 't))
+ (tmp #C(0.0d0 0.0d0)) (anrm 0.0d0)
+ (bignum 0.0d0) (cscale 0.0d0) (eps 0.0d0) (scl 0.0d0) (smlnum 0.0d0)
+ (hswork 0) (i 0) (ibal 0) (ierr 0) (ihi 0) (ilo 0) (irwork 0) (itau 0)
+ (iwrk 0) (k 0) (maxwrk 0) (minwrk 0) (nout 0)
+ (side (make-array '(1) :element-type 'character
+ :initial-element #\space))
+ (lquery nil) (scalea nil) (wantvl nil) (wantvr nil))
+ (declare (type (array double-float (1)) dum)
+ (type (array f2cl-lib:logical (1)) select)
+ (type (f2cl-lib:complex16) tmp)
+ (type (double-float) smlnum scl eps cscale bignum anrm)
+ (type (f2cl-lib:integer4) nout minwrk maxwrk k iwrk itau irwork
+ ilo ihi ierr
+ ibal i hswork)
+ (type (simple-array character (1)) side)
+ (type f2cl-lib:logical wantvr wantvl scalea lquery))
+ (setf info 0) (setf lquery (coerce (= lwork -1) 'f2cl-lib:logical))
+ (setf wantvl
+ (multiple-value-bind (ret-val var-0 var-1) (lsame jobvl "V")
+ (declare (ignore var-1)) (when var-0 (setf jobvl var-0)) ret-val))
+ (setf wantvr
+ (multiple-value-bind (ret-val var-0 var-1) (lsame jobvr "V")
+ (declare (ignore var-1)) (when var-0 (setf jobvr var-0)) ret-val))
+ (cond
+ ((and (not wantvl)
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame jobvl "N")
+ (declare (ignore var-1))
+ (when var-0 (setf jobvl var-0)) ret-val)))
+ (setf info -1))
+ ((and (not wantvr)
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame jobvr "N")
+ (declare (ignore var-1))
+ (when var-0 (setf jobvr var-0)) ret-val)))
+ (setf info -2))
+ ((< n 0) (setf info -3))
+ ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n)))
+ (setf info -5))
+ ((or (< ldvl 1) (and wantvl (< ldvl n))) (setf info -8))
+ ((or (< ldvr 1) (and wantvr (< ldvr n))) (setf info -10)))
+ (cond
+ ((= info 0)
+ (cond ((= n 0) (setf minwrk 1) (setf maxwrk 1))
+ (t
+ (setf maxwrk
+ (f2cl-lib:int-add n
+ (f2cl-lib:int-mul n
+ (multiple-value-bind
+ (ret-val var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (ilaenv 1 "ZGEHRD" " " n 1 n 0)
+ (declare (ignore var-0 var-1 var-2 var-4 var-6))
+ (when var-3 (setf n var-3))
+ (when var-5 (setf n var-5)) ret-val))))
+ (setf minwrk (f2cl-lib:int-mul 2 n))
+ (cond
+ (wantvl
+ (setf maxwrk
+ (max (the f2cl-lib:integer4 maxwrk)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add n
+ (f2cl-lib:int-mul (f2cl-lib:int-sub n 1)
+ (multiple-value-bind
+ (ret-val var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (ilaenv 1 "ZUNGHR" " " n 1 n -1)
+ (declare (ignore var-0 var-1 var-2 var-4 var-6))
+ (when var-3 (setf n var-3)) (when var-5 (setf n var-5))
+ ret-val))))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
+ var-10
+ var-11 var-12)
+ (zhseqr "S" "V" n 1 n a lda w vl ldvl work -1 info)
+ (declare (ignore var-0 var-1 var-3 var-5 var-7 var-8 var-10
+ var-11))
+ (when var-2 (setf n var-2)) (when var-4 (setf n var-4))
+ (when var-6 (setf lda var-6)) (when var-9 (setf ldvl var-9))
+ (when var-12 (setf info var-12))))
+ (wantvr
+ (setf maxwrk
+ (max (the f2cl-lib:integer4 maxwrk)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add n
+ (f2cl-lib:int-mul (f2cl-lib:int-sub n 1)
+ (multiple-value-bind
+ (ret-val var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (ilaenv 1 "ZUNGHR" " " n 1 n -1)
+ (declare (ignore var-0 var-1 var-2 var-4 var-6))
+ (when var-3 (setf n var-3)) (when var-5 (setf n var-5))
+ ret-val))))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
+ var-10
+ var-11 var-12)
+ (zhseqr "S" "V" n 1 n a lda w vr ldvr work -1 info)
+ (declare (ignore var-0 var-1 var-3 var-5 var-7 var-8 var-10
+ var-11))
+ (when var-2 (setf n var-2)) (when var-4 (setf n var-4))
+ (when var-6 (setf lda var-6)) (when var-9 (setf ldvr var-9))
+ (when var-12 (setf info var-12))))
+ (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)
+ (zhseqr "E" "N" n 1 n a lda w vr ldvr work -1 info)
+ (declare (ignore var-0 var-1 var-3 var-5 var-7 var-8 var-10
+ var-11))
+ (when var-2 (setf n var-2)) (when var-4 (setf n var-4))
+ (when var-6 (setf lda var-6)) (when var-9 (setf ldvr var-9))
+ (when var-12 (setf info var-12)))))
+ (setf hswork
+ (f2cl-lib:int (f2cl-lib:fref work-%data% (1) ((1 *))
+ work-%offset%)))
+ (setf maxwrk
+ (max (the f2cl-lib:integer4 maxwrk) (the f2cl-lib:integer4 hswork)
+ (the f2cl-lib:integer4 minwrk)))))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (coerce maxwrk 'f2cl-lib:complex16))
+ (cond ((and (< lwork minwrk) (not lquery)) (setf info -12)))))
+ (cond ((/= info 0)
+ (xerbla "ZGEEV " (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))
+ (when var-0 (setf smlnum var-0)) (when var-1 (setf bignum var-1)))
+ (setf smlnum (/ (f2cl-lib:fsqrt smlnum) eps))
+ (setf bignum (/ one smlnum))
+ (setf anrm
+ (multiple-value-bind (ret-val var-0 var-1 var-2 var-3 var-4 var-5)
+ (zlange "M" n n a lda dum) (declare (ignore var-0 var-3 var-5))
+ (when var-1 (setf n var-1)) (when var-2 (setf n var-2))
+ (when var-4 (setf lda var-4)) ret-val))
+ (setf scalea f2cl-lib:%false%)
+ (cond
+ ((and (> anrm zero) (< anrm smlnum)) (setf scalea f2cl-lib:%true%)
+ (setf cscale smlnum))
+ ((> anrm bignum) (setf scalea f2cl-lib:%true%) (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)
+ (zlascl "G" 0 0 anrm cscale n n a lda ierr)
+ (declare (ignore var-0 var-1 var-2 var-7))
+ (when var-3 (setf anrm var-3))
+ (when var-4 (setf cscale var-4)) (when var-5 (setf n var-5))
+ (when var-6 (setf n var-6)) (when var-8 (setf lda var-8))
+ (when var-9 (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)
+ (zgebal "B" n a lda ilo ihi
+ (f2cl-lib:array-slice rwork-%data% double-float (ibal) ((1 *))
+ rwork-%offset%)
+ ierr)
+ (declare (ignore var-0 var-1 var-2 var-6))
+ (setf lda var-3) (setf ilo var-4)
+ (setf ihi var-5) (setf ierr var-7))
+ (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)
+ (zgehrd n ilo ihi a lda
+ (f2cl-lib:array-slice work-%data% f2cl-lib:complex16 (itau) ((1 *))
+ work-%offset%)
+ (f2cl-lib:array-slice work-%data% f2cl-lib:complex16 (iwrk) ((1 *))
+ work-%offset%)
+ (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwrk) 1) ierr)
+ (declare (ignore var-3 var-5 var-6 var-7)) (when var-0 (setf n var-0))
+ (when var-1 (setf ilo var-1)) (when var-2 (setf ihi var-2))
+ (when var-4 (setf lda var-4)) (when var-8 (setf ierr var-8)))
+ (cond
+ (wantvl (f2cl-lib:f2cl-set-string side "L" (string 1))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (zlacpy "L" n n a lda vl ldvl) (declare (ignore var-0 var-3 var-5))
+ (when var-1 (setf n var-1)) (when var-2 (setf n var-2))
+ (when var-4 (setf lda var-4)) (when var-6 (setf ldvl var-6)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
+ (zunghr n ilo ihi vl ldvl
+ (f2cl-lib:array-slice work-%data% f2cl-lib:complex16 (itau) ((1 *))
+ work-%offset%)
+ (f2cl-lib:array-slice work-%data% f2cl-lib:complex16 (iwrk) ((1 *))
+ work-%offset%)
+ (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwrk) 1) ierr)
+ (declare (ignore var-3 var-5 var-6 var-7))
+ (when var-0 (setf n var-0))
+ (when var-1 (setf ilo var-1)) (when var-2 (setf ihi var-2))
+ (when var-4 (setf ldvl var-4)) (when var-8 (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)
+ (zhseqr "S" "V" n ilo ihi a lda w vl ldvl
+ (f2cl-lib:array-slice work-%data% f2cl-lib:complex16 (iwrk) ((1 *))
+ work-%offset%)
+ (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwrk) 1) info)
+ (declare (ignore var-0 var-1 var-5 var-7 var-8 var-10 var-11))
+ (when var-2 (setf n var-2)) (when var-3 (setf ilo var-3))
+ (when var-4 (setf ihi var-4)) (when var-6 (setf lda var-6))
+ (when var-9 (setf ldvl var-9)) (when var-12 (setf info var-12)))
+ (cond
+ (wantvr (f2cl-lib:f2cl-set-string side "B" (string 1))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (zlacpy "F" n n vl ldvl vr ldvr)
+ (declare (ignore var-0 var-3 var-5))
+ (when var-1 (setf n var-1)) (when var-2 (setf n var-2))
+ (when var-4 (setf ldvl var-4)) (when var-6 (setf ldvr var-6))))))
+ (wantvr (f2cl-lib:f2cl-set-string side "R" (string 1))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (zlacpy "L" n n a lda vr ldvr) (declare (ignore var-0 var-3 var-5))
+ (when var-1 (setf n var-1)) (when var-2 (setf n var-2))
+ (when var-4 (setf lda var-4)) (when var-6 (setf ldvr var-6)))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6
+ var-7 var-8)
+ (zunghr n ilo ihi vr ldvr
+ (f2cl-lib:array-slice work-%data% f2cl-lib:complex16 (itau) ((1 *))
+ work-%offset%)
+ (f2cl-lib:array-slice work-%data% f2cl-lib:complex16 (iwrk) ((1 *))
+ work-%offset%)
+ (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwrk) 1) ierr)
+ (declare (ignore var-3 var-5 var-6 var-7))
+ (when var-0 (setf n var-0))
+ (when var-1 (setf ilo var-1)) (when var-2 (setf ihi var-2))
+ (when var-4 (setf ldvr var-4)) (when var-8 (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)
+ (zhseqr "S" "V" n ilo ihi a lda w vr ldvr
+ (f2cl-lib:array-slice work-%data% f2cl-lib:complex16 (iwrk) ((1 *))
+ work-%offset%)
+ (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwrk) 1) info)
+ (declare (ignore var-0 var-1 var-5 var-7 var-8 var-10 var-11))
+ (when var-2 (setf n var-2)) (when var-3 (setf ilo var-3))
+ (when var-4 (setf ihi var-4)) (when var-6 (setf lda var-6))
+ (when var-9 (setf ldvr var-9)) (when var-12 (setf info var-12))))
+ (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)
+ (zhseqr "E" "N" n ilo ihi a lda w vr ldvr
+ (f2cl-lib:array-slice work-%data% f2cl-lib:complex16 (iwrk) ((1 *))
+ work-%offset%)
+ (f2cl-lib:int-add (f2cl-lib:int-sub lwork iwrk) 1) info)
+ (declare (ignore var-0 var-1 var-5 var-7 var-8 var-10 var-11))
+ (when var-2 (setf n var-2)) (when var-3 (setf ilo var-3))
+ (when var-4 (setf ihi var-4)) (when var-6 (setf lda var-6))
+ (when var-9 (setf ldvr var-9)) (when var-12 (setf info var-12)))))
+ (if (> info 0) (go label50))
+ (cond
+ ((or wantvl wantvr) (setf irwork (f2cl-lib:int-add ibal 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)
+ (ztrevc side "B" select n a lda vl ldvl vr ldvr n nout
+ (f2cl-lib:array-slice work-%data% f2cl-lib:complex16 (iwrk) ((1 *))
+ work-%offset%)
+ (f2cl-lib:array-slice rwork-%data% double-float (irwork) ((1 *))
+ rwork-%offset%)
+ ierr)
+ (declare (ignore var-1 var-2 var-4 var-6 var-8 var-12 var-13))
+ (when var-0 (setf side var-0)) (when var-3 (setf n var-3))
+ (when var-5 (setf lda var-5)) (when var-7 (setf ldvl var-7))
+ (when var-9 (setf ldvr var-9)) (when var-10 (setf n var-10))
+ (when var-11 (setf nout var-11)) (when var-14 (setf ierr var-14)))))
+ (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)
+ (zgebak "B" "L" n ilo ihi
+ (f2cl-lib:array-slice rwork-%data% double-float (ibal) ((1 *))
+ rwork-%offset%)
+ n vl ldvl ierr)
+ (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-7))
+ (setf n var-6)
+ (setf ldvl var-8) (setf ierr var-9))
+ (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
+ ((> i n) nil)
+ (tagbody
+ (setf scl
+ (/ one
+ (multiple-value-bind (ret-val var-0 var-1 var-2)
+ (dznrm2 n
+ (f2cl-lib:array-slice vl-%data% f2cl-lib:complex16 (1 i)
+ ((1 ldvl) (1 *)) vl-%offset%)
+ 1)
+ (declare (ignore var-1 var-2))
+ (when var-0 (setf n var-0)) ret-val)))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zdscal n scl
+ (f2cl-lib:array-slice vl-%data% f2cl-lib:complex16
+ (1 i) ((1 ldvl) (1 *))
+ vl-%offset%)
+ 1)
+ (declare (ignore var-2 var-3))
+ (when var-0 (setf n var-0))
+ (when var-1 (setf scl var-1)))
+ (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
+ ((> k n) nil)
+ (tagbody
+ (setf
+ (f2cl-lib:fref rwork-%data%
+ ((f2cl-lib:int-sub (f2cl-lib:int-add irwork k) 1))
+ ((1 *))
+ rwork-%offset%)
+ (+
+ (expt
+ (f2cl-lib:dble
+ (f2cl-lib:fref vl-%data% (k i) ((1 ldvl) (1 *))
+ vl-%offset%))
+ 2)
+ (expt
+ (f2cl-lib:dimag
+ (f2cl-lib:fref vl-%data% (k i) ((1 ldvl) (1 *))
+ vl-%offset%))
+ 2)))
+ label10))
+ (setf k
+ (multiple-value-bind (ret-val var-0 var-1 var-2)
+ (idamax n
+ (f2cl-lib:array-slice rwork-%data% double-float
+ (irwork) ((1 *))
+ rwork-%offset%)
+ 1)
+ (declare (ignore var-1 var-2))
+ (when var-0 (setf n var-0)) ret-val))
+ (setf tmp
+ (coerce
+ (/
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref vl-%data% (k i) ((1 ldvl) (1 *))
+ vl-%offset%))
+ (f2cl-lib:fsqrt
+ (f2cl-lib:fref rwork-%data%
+ ((f2cl-lib:int-sub (f2cl-lib:int-add irwork k) 1))
+ ((1 *))
+ rwork-%offset%)))
+ 'f2cl-lib:complex16))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zscal n tmp
+ (f2cl-lib:array-slice vl-%data% f2cl-lib:complex16
+ (1 i) ((1 ldvl) (1 *))
+ vl-%offset%)
+ 1)
+ (declare (ignore var-2 var-3))
+ (when var-0 (setf n var-0))
+ (when var-1 (setf tmp var-1)))
+ (setf (f2cl-lib:fref vl-%data% (k i) ((1 ldvl) (1 *))
+ vl-%offset%)
+ (f2cl-lib:dcmplx
+ (f2cl-lib:dble
+ (f2cl-lib:fref vl-%data% (k i) ((1 ldvl) (1 *))
+ vl-%offset%))
+ zero))
+ label20))))
+ (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)
+ (zgebak "B" "R" n ilo ihi
+ (f2cl-lib:array-slice rwork-%data% double-float (ibal) ((1 *))
+ rwork-%offset%)
+ n vr ldvr ierr)
+ (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-7))
+ (setf n var-6)
+ (setf ldvr var-8) (setf ierr var-9))
+ (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
+ ((> i n) nil)
+ (tagbody
+ (setf scl
+ (/ one
+ (multiple-value-bind (ret-val var-0 var-1 var-2)
+ (dznrm2 n
+ (f2cl-lib:array-slice vr-%data% f2cl-lib:complex16
+ (1 i)
+ ((1 ldvr) (1 *)) vr-%offset%)
+ 1)
+ (declare (ignore var-1 var-2))
+ (when var-0 (setf n var-0)) ret-val)))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zdscal n scl
+ (f2cl-lib:array-slice vr-%data% f2cl-lib:complex16
+ (1 i) ((1 ldvr) (1 *))
+ vr-%offset%)
+ 1)
+ (declare (ignore var-2 var-3))
+ (when var-0 (setf n var-0))
+ (when var-1 (setf scl var-1)))
+ (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
+ ((> k n) nil)
+ (tagbody
+ (setf
+ (f2cl-lib:fref rwork-%data%
+ ((f2cl-lib:int-sub (f2cl-lib:int-add irwork k) 1))
+ ((1 *))
+ rwork-%offset%)
+ (+
+ (expt
+ (f2cl-lib:dble
+ (f2cl-lib:fref vr-%data% (k i) ((1 ldvr) (1 *))
+ vr-%offset%))
+ 2)
+ (expt
+ (f2cl-lib:dimag
+ (f2cl-lib:fref vr-%data% (k i) ((1 ldvr) (1 *))
+ vr-%offset%))
+ 2)))
+ label30))
+ (setf k
+ (multiple-value-bind (ret-val var-0 var-1 var-2)
+ (idamax n
+ (f2cl-lib:array-slice rwork-%data% double-float
+ (irwork) ((1 *))
+ rwork-%offset%)
+ 1)
+ (declare (ignore var-1 var-2))
+ (when var-0 (setf n var-0)) ret-val))
+ (setf tmp
+ (coerce
+ (/
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref vr-%data% (k i) ((1 ldvr) (1 *))
+ vr-%offset%))
+ (f2cl-lib:fsqrt
+ (f2cl-lib:fref rwork-%data%
+ ((f2cl-lib:int-sub (f2cl-lib:int-add irwork k) 1))
+ ((1 *))
+ rwork-%offset%)))
+ 'f2cl-lib:complex16))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zscal n tmp
+ (f2cl-lib:array-slice vr-%data% f2cl-lib:complex16
+ (1 i) ((1 ldvr) (1 *))
+ vr-%offset%)
+ 1)
+ (declare (ignore var-2 var-3)) (when var-0 (setf n var-0))
+ (when var-1 (setf tmp var-1)))
+ (setf (f2cl-lib:fref vr-%data% (k i) ((1 ldvr) (1 *))
+ vr-%offset%)
+ (f2cl-lib:dcmplx
+ (f2cl-lib:dble
+ (f2cl-lib:fref vr-%data% (k i) ((1 ldvr) (1 *))
+ vr-%offset%))
+ zero))
+ label40))))
+ 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)
+ (zlascl "G" 0 0 cscale anrm (f2cl-lib:int-sub n info) 1
+ (f2cl-lib:array-slice w-%data% f2cl-lib:complex16
+ ((+ info 1)) ((1 *))
+ w-%offset%)
+ (max (the f2cl-lib:integer4 (f2cl-lib:int-sub n info))
+ (the f2cl-lib:integer4 1))
+ ierr)
+ (declare (ignore var-0 var-1 var-2 var-5 var-6 var-7 var-8))
+ (when var-3 (setf cscale var-3)) (when var-4 (setf anrm var-4))
+ (when var-9 (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)
+ (zlascl "G" 0 0 cscale anrm (f2cl-lib:int-sub ilo 1) 1 w n ierr)
+ (declare (ignore var-0 var-1 var-2 var-5 var-6 var-7))
+ (when var-3 (setf cscale var-3)) (when var-4 (setf anrm var-4))
+ (when var-8 (setf n var-8)) (when var-9 (setf ierr var-9)))))))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (coerce maxwrk 'f2cl-lib:complex16))
+ (go end_label) end_label
+ (return
+ (values jobvl jobvr n nil lda nil nil ldvl nil
+ ldvr nil nil nil info)))
+ )))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -108628,7 +112987,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zgehd2.f}
* =====================================================================
SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
*
@@ -108706,10 +113065,102 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zgehd2}
-
+(let* ((one (coerce (f2cl-lib:cmplx 1.0d0 0.0d0) 'f2cl-lib:complex16)))
+ (declare (type (f2cl-lib:complex16) one) (ignorable one))
+ (defun zgehd2 (n ilo ihi a lda tau work info)
+ (declare (type (f2cl-lib:integer4) info lda ihi ilo n)
+ (type (array f2cl-lib:complex16 (*)) work tau a))
+ (f2cl-lib:with-multi-array-data
+ ((a f2cl-lib:complex16 a-%data% a-%offset%)
+ (tau f2cl-lib:complex16 tau-%data% tau-%offset%)
+ (work f2cl-lib:complex16 work-%data% work-%offset%))
+ (prog
+ ((alpha #C(0.0d0 0.0d0)) (i 0) (dconjg$ 0.0))
+ (declare (type (f2cl-lib:complex16) alpha) (type (f2cl-lib:integer4) i)
+ (type (single-float) dconjg$))
+ (setf info 0)
+ (cond ((< n 0) (setf info -1))
+ ((or (< ilo 1)
+ (> ilo (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n))))
+ (setf info -2))
+ ((or (< ihi (min (the f2cl-lib:integer4 ilo)
+ (the f2cl-lib:integer4 n)))
+ (> ihi n))
+ (setf info -3))
+ ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n)))
+ (setf info -5)))
+ (cond ((/= info 0)
+ (xerbla "ZGEHD2" (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
+ (setf alpha
+ (f2cl-lib:fref a-%data% ((f2cl-lib:int-add i 1) i)
+ ((1 lda) (1 *))
+ a-%offset%))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
+ (zlarfg (f2cl-lib:int-sub ihi i) alpha
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((min (f2cl-lib:int-add i 2) n) i) ((1 lda) (1 *))
+ a-%offset%)
+ 1
+ (f2cl-lib:array-slice tau-%data% f2cl-lib:complex16
+ (i) ((1 *))
+ tau-%offset%))
+ (declare (ignore var-0 var-2 var-3 var-4))
+ (when var-1 (setf alpha var-1)))
+ (setf
+ (f2cl-lib:fref a-%data% ((f2cl-lib:int-add i 1) i)
+ ((1 lda) (1 *))
+ a-%offset%)
+ one)
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5
+ var-6 var-7 var-8)
+ (zlarf "Right" ihi (f2cl-lib:int-sub ihi i)
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ i 1) i)
+ ((1 lda) (1 *)) a-%offset%)
+ 1
+ (f2cl-lib:array-slice tau-%data% f2cl-lib:complex16
+ (i) ((1 *))
+ tau-%offset%)
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ (1 (f2cl-lib:int-add i 1)) ((1 lda) (1 *)) a-%offset%)
+ lda work)
+ (declare (ignore var-0 var-2 var-3 var-4 var-5 var-6 var-8))
+ (when var-1 (setf ihi var-1)) (when var-7 (setf lda var-7)))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5
+ var-6 var-7 var-8)
+ (zlarf "Left" (f2cl-lib:int-sub ihi i)
+ (f2cl-lib:int-sub n i)
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ i 1) i)
+ ((1 lda) (1 *)) a-%offset%)
+ 1 (f2cl-lib:dconjg (f2cl-lib:fref tau-%data% (i) ((1 *))
+ tau-%offset%))
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ i 1) (f2cl-lib:int-add i 1)) ((1 lda) (1 *))
+ a-%offset%)
+ lda work)
+ (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5
+ var-6 var-8))
+ (when var-7 (setf lda var-7)))
+ (setf
+ (f2cl-lib:fref a-%data% ((f2cl-lib:int-add i 1) i)
+ ((1 lda) (1 *))
+ a-%offset%)
+ alpha)
+ label10))
+ (go end_label)
+ end_label
+ (return (values nil nil ihi nil lda nil nil info)))
+ )))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -108875,7 +113326,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zgehrd.f}
* =====================================================================
SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
*
@@ -109062,10 +113513,269 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zgehrd}
-
+(let*
+ ((nbmax 64) (ldt (+ nbmax 1))
+ (zero (coerce (f2cl-lib:cmplx 0.0d0 0.0d0) 'f2cl-lib:complex16))
+ (one (coerce (f2cl-lib:cmplx 1.0d0 0.0d0) 'f2cl-lib:complex16)))
+ (declare (type (f2cl-lib:integer4 64 64) nbmax) (type (f2cl-lib:integer4) ldt)
+ (type (f2cl-lib:complex16) zero) (type (f2cl-lib:complex16) one)
+ (ignorable nbmax ldt zero one))
+ (defun zgehrd (n ilo ihi a lda tau work lwork info)
+ (declare (type (f2cl-lib:integer4) info lwork lda ihi ilo n)
+ (type (array f2cl-lib:complex16 (*)) work tau a))
+ (f2cl-lib:with-multi-array-data
+ ((a f2cl-lib:complex16 a-%data% a-%offset%)
+ (tau f2cl-lib:complex16 tau-%data% tau-%offset%)
+ (work f2cl-lib:complex16 work-%data% work-%offset%))
+ (prog
+ ((ei #C(0.0d0 0.0d0)) (i 0) (ib 0) (iinfo 0) (iws 0) (j 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
+ 'f2cl-lib:complex16)))
+ (declare (type (f2cl-lib:complex16) ei)
+ (type (f2cl-lib:integer4)
+ nx nh nbmin nb lwkopt ldwork j iws iinfo ib i)
+ (type f2cl-lib:logical lquery)
+ (type (array f2cl-lib:complex16 (*)) t$))
+ (setf info 0)
+ (setf nb
+ (min (the f2cl-lib:integer4 nbmax)
+ (the f2cl-lib:integer4
+ (multiple-value-bind
+ (ret-val var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (ilaenv 1 "ZGEHRD" " " n ilo ihi -1)
+ (declare (ignore var-0 var-1 var-2 var-6))
+ (when var-3 (setf n var-3))
+ (when var-4 (setf ilo var-4))
+ (when var-5 (setf ihi var-5)) ret-val))))
+ (setf lwkopt (f2cl-lib:int-mul n nb))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (coerce lwkopt 'f2cl-lib:complex16))
+ (setf lquery (coerce (= lwork -1) 'f2cl-lib:logical))
+ (cond ((< n 0) (setf info -1))
+ ((or (< ilo 1)
+ (> ilo (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n))))
+ (setf info -2))
+ ((or (< ihi (min (the f2cl-lib:integer4 ilo)
+ (the f2cl-lib:integer4 n)))
+ (> ihi n))
+ (setf info -3))
+ ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n)))
+ (setf info -5))
+ ((and (< lwork (max (the f2cl-lib:integer4 1)
+ (the f2cl-lib:integer4 n)))
+ (not lquery))
+ (setf info -8)))
+ (cond ((/= info 0)
+ (xerbla "ZGEHRD" (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) label10)
+ )
+ (f2cl-lib:fdo (i (max (the f2cl-lib:integer4 1)
+ (the f2cl-lib:integer4 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) label20)
+ )
+ (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 1 'f2cl-lib:complex16))
+ (go end_label)))
+ (setf nb
+ (min (the f2cl-lib:integer4 nbmax)
+ (the f2cl-lib:integer4
+ (multiple-value-bind (ret-val var-0 var-1 var-2 var-3 var-4
+ var-5 var-6)
+ (ilaenv 1 "ZGEHRD" " " n ilo ihi -1)
+ (declare (ignore var-0 var-1 var-2 var-6))
+ (when var-3 (setf n var-3))
+ (when var-4 (setf ilo var-4))
+ (when var-5 (setf ihi var-5)) ret-val))))
+ (setf nbmin 2) (setf iws 1)
+ (cond
+ ((and (> nb 1) (< nb nh))
+ (setf nx
+ (max (the f2cl-lib:integer4 nb)
+ (the f2cl-lib:integer4
+ (multiple-value-bind (ret-val var-0 var-1 var-2 var-3 var-4
+ var-5 var-6)
+ (ilaenv 3 "ZGEHRD" " " n ilo ihi -1)
+ (declare (ignore var-0 var-1 var-2 var-6))
+ (when var-3 (setf n var-3))
+ (when var-4 (setf ilo var-4))
+ (when var-5 (setf ihi var-5)) ret-val))))
+ (cond
+ ((< nx nh) (setf iws (f2cl-lib:int-mul n nb))
+ (cond
+ ((< lwork iws)
+ (setf nbmin
+ (max (the f2cl-lib:integer4 2)
+ (the f2cl-lib:integer4
+ (multiple-value-bind
+ (ret-val var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (ilaenv 2 "ZGEHRD" " " n ilo ihi -1)
+ (declare (ignore var-0 var-1 var-2 var-6))
+ (when var-3 (setf n var-3)) (when var-4 (setf ilo var-4))
+ (when var-5 (setf ihi var-5)) ret-val))))
+ (cond
+ ((>= lwork (f2cl-lib:int-mul n nbmin))
+ (setf nb (the f2cl-lib:integer4 (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 f2cl-lib:integer4 nb)
+ (the f2cl-lib:integer4 (f2cl-lib:int-sub ihi i))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9)
+ (zlahr2 ihi i ib
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ (1 i) ((1 lda) (1 *))
+ a-%offset%)
+ lda
+ (f2cl-lib:array-slice tau-%data% f2cl-lib:complex16
+ (i) ((1 *))
+ tau-%offset%)
+ t$ ldt work ldwork)
+ (declare (ignore var-3 var-5 var-6 var-8))
+ (when var-0 (setf ihi var-0))
+ (when var-1 (setf i var-1)) (when var-2 (setf ib var-2))
+ (when var-4 (setf lda var-4))
+ (when var-7 (setf ldt var-7))
+ (when var-9 (setf ldwork var-9)))
+ (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)
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10 var-11
+ var-12)
+ (zgemm "No transpose" "Conjugate transpose" ihi
+ (f2cl-lib:int-add (f2cl-lib:int-sub ihi i ib) 1)
+ ib (- one) work ldwork
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ i ib) i)
+ ((1 lda) (1 *)) a-%offset%)
+ lda one
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ (1 (f2cl-lib:int-add i ib)) ((1 lda) (1 *))
+ a-%offset%)
+ lda)
+ (declare (ignore var-0 var-1 var-3 var-5 var-6
+ var-8 var-11))
+ (when var-2 (setf ihi var-2))
+ (when var-4 (setf ib var-4))
+ (when var-7 (setf ldwork var-7))
+ (when var-9 (setf lda var-9))
+ (when var-10 (setf one var-10))
+ (when var-12 (setf lda var-12)))
+ (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)
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Lower" "Conjugate transpose" "Unit" i
+ (f2cl-lib:int-sub ib 1) one
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ i 1) i)
+ ((1 lda) (1 *)) a-%offset%)
+ lda work ldwork)
+ (declare (ignore var-0 var-1 var-2 var-3 var-5
+ var-7 var-9))
+ (when var-4 (setf i var-4))
+ (when var-6 (setf one var-6))
+ (when var-8 (setf lda var-8))
+ (when var-10 (setf ldwork var-10)))
+ (f2cl-lib:fdo (j 0 (f2cl-lib:int-add j 1))
+ ((> j
+ (f2cl-lib:int-add ib (f2cl-lib:int-sub 2)))
+ nil)
+ (tagbody
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4
+ var-5)
+ (zaxpy i (- one)
+ (f2cl-lib:array-slice work-%data% f2cl-lib:complex16
+ ((+ (f2cl-lib:int-mul ldwork j) 1)) ((1 *))
+ work-%offset%)
+ 1
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ (1 (f2cl-lib:int-add i j 1)) ((1 lda) (1 *))
+ a-%offset%)
+ 1)
+ (declare (ignore var-1 var-2 var-3 var-4 var-5))
+ (when var-0 (setf i var-0)))
+ label30))
+ (multiple-value-bind
+ (var-0 var-1 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)
+ (zlarfb "Left" "Conjugate 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-%data% f2cl-lib:complex16
+ ((+ i 1) i)
+ ((1 lda) (1 *)) a-%offset%)
+ lda t$ ldt
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ i 1) (f2cl-lib:int-add i ib)) ((1 lda) (1 *))
+ a-%offset%)
+ lda work ldwork)
+ (declare
+ (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-7
+ var-9 var-11 var-13))
+ (when var-6 (setf ib var-6))
+ (when var-8 (setf lda var-8))
+ (when var-10 (setf ldt var-10))
+ (when var-12 (setf lda var-12))
+ (when var-14 (setf ldwork var-14)))
+ label40))))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)
+ (zgehd2 n i ihi a lda tau work iinfo)
+ (declare (ignore var-0 var-1 var-3 var-5 var-6)) (setf ihi var-2)
+ (setf lda var-4) (setf iinfo var-7))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (coerce iws 'f2cl-lib:complex16))
+ (go end_label)
+ end_label
+ (return (values n ilo ihi nil lda nil nil nil info)))
+ )))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -109359,7 +114069,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zhseqr.f}
* =====================================================================
SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ,
$ WORK, LWORK, INFO )
@@ -109562,10 +114272,255 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zhseqr}
-
+(let*
+ ((ntiny 11) (nl 49)
+ (zero (coerce (f2cl-lib:cmplx 0.0d0 0.0d0) 'f2cl-lib:complex16))
+ (one (coerce (f2cl-lib:cmplx 1.0d0 0.0d0) 'f2cl-lib:complex16))
+ (rzero 0.0d0))
+ (declare (type (f2cl-lib:integer4 11 11) ntiny)
+ (type (f2cl-lib:integer4 49 49) nl) (type (f2cl-lib:complex16) zero)
+ (type (f2cl-lib:complex16) one) (type (double-float 0.0d0 0.0d0) rzero)
+ (ignorable ntiny nl zero one rzero))
+ (defun zhseqr (job compz n ilo ihi h ldh w z ldz work lwork info)
+ (declare (type (simple-array character (*)) compz job)
+ (type (f2cl-lib:integer4) info lwork ldz ldh ihi ilo n)
+ (type (array f2cl-lib:complex16 (*)) work z w h))
+ (f2cl-lib:with-multi-array-data
+ ((h f2cl-lib:complex16 h-%data% h-%offset%)
+ (w f2cl-lib:complex16 w-%data% w-%offset%)
+ (z f2cl-lib:complex16 z-%data% z-%offset%)
+ (work f2cl-lib:complex16 work-%data% work-%offset%)
+ (job character job-%data% job-%offset%)
+ (compz character compz-%data% compz-%offset%))
+ (prog
+ ((initz nil) (lquery nil) (wantt nil) (wantz nil) (kbot 0) (nmin 0)
+ (hl
+ (make-array (the fixnum (reduce #'* (list nl nl))) :element-type
+ 'f2cl-lib:complex16))
+ (workl (make-array nl :element-type 'f2cl-lib:complex16)))
+ (declare (type f2cl-lib:logical wantz wantt lquery initz)
+ (type (f2cl-lib:integer4) nmin kbot)
+ (type (array f2cl-lib:complex16 (*)) workl hl))
+ (setf wantt
+ (multiple-value-bind (ret-val var-0 var-1) (lsame job "S")
+ (declare (ignore var-1)) (when var-0 (setf job var-0)) ret-val))
+ (setf initz
+ (multiple-value-bind (ret-val var-0 var-1) (lsame compz "I")
+ (declare (ignore var-1)) (when var-0 (setf compz var-0)) ret-val))
+ (setf wantz
+ (or initz
+ (multiple-value-bind (ret-val var-0 var-1) (lsame compz "V")
+ (declare (ignore var-1)) (when var-0 (setf compz var-0)) ret-val)))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (f2cl-lib:dcmplx
+ (f2cl-lib:dble (max (the f2cl-lib:integer4 1)
+ (the f2cl-lib:integer4 n)))
+ rzero))
+ (setf lquery (coerce (= lwork -1) 'f2cl-lib:logical)) (setf info 0)
+ (cond
+ ((and
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame job "E")
+ (declare (ignore var-1)) (when var-0 (setf job var-0)) ret-val))
+ (not wantt))
+ (setf info -1))
+ ((and
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame compz "N")
+ (declare (ignore var-1)) (when var-0 (setf compz var-0)) ret-val))
+ (not wantz))
+ (setf info -2))
+ ((< n 0) (setf info -3))
+ ((or (< ilo 1)
+ (> ilo (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n))))
+ (setf info -4))
+ ((or (< ihi (min (the f2cl-lib:integer4 ilo)
+ (the f2cl-lib:integer4 n)))
+ (> ihi n))
+ (setf info -5))
+ ((< ldh (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n)))
+ (setf info -7))
+ ((or (< ldz 1)
+ (and wantz
+ (< ldz (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n)))))
+ (setf info -10))
+ ((and (< lwork (max (the f2cl-lib:integer4 1)
+ (the f2cl-lib:integer4 n)))
+ (not lquery))
+ (setf info -12)))
+ (cond ((/= info 0)
+ (xerbla "ZHSEQR" (f2cl-lib:int-sub info))
+ (go end_label))
+ ((= n 0) (go end_label))
+ (lquery
+ (multiple-value-bind
+ (var-0 var-1 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)
+ (zlaqr0 wantt wantz n ilo ihi h ldh w ilo ihi z ldz work lwork info)
+ (declare (ignore var-5 var-7 var-10 var-12))
+ (when var-0 (setf wantt var-0)) (when var-1 (setf wantz var-1))
+ (when var-2 (setf n var-2)) (when var-3 (setf ilo var-3))
+ (when var-4 (setf ihi var-4)) (when var-6 (setf ldh var-6))
+ (when var-8 (setf ilo var-8)) (when var-9 (setf ihi var-9))
+ (when var-11 (setf ldz var-11)) (when var-13 (setf lwork var-13))
+ (when var-14 (setf info var-14)))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (f2cl-lib:dcmplx
+ (max (f2cl-lib:dble (f2cl-lib:fref work-%data% (1) ((1 *))
+ work-%offset%))
+ (f2cl-lib:dble
+ (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n))))
+ rzero))
+ (go end_label))
+ (t
+ (if (> ilo 1)
+ (zcopy (f2cl-lib:int-sub ilo 1) h (f2cl-lib:int-add ldh 1) w 1))
+ (if (< ihi n)
+ (zcopy (f2cl-lib:int-sub n ihi)
+ (f2cl-lib:array-slice h-%data% f2cl-lib:complex16
+ ((+ ihi 1) (f2cl-lib:int-add ihi 1)) ((1 ldh) (1 *)) h-%offset%)
+ (f2cl-lib:int-add ldh 1)
+ (f2cl-lib:array-slice w-%data% f2cl-lib:complex16
+ ((+ ihi 1)) ((1 *))
+ w-%offset%)
+ 1))
+ (if initz
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (zlaset "A" n n zero one z ldz) (declare (ignore var-0 var-5))
+ (when var-1 (setf n var-1)) (when var-2 (setf n var-2))
+ (when var-3 (setf zero var-3)) (when var-4 (setf one var-4))
+ (when var-6 (setf ldz var-6))))
+ (cond
+ ((= ilo ihi)
+ (setf (f2cl-lib:fref w-%data% (ilo) ((1 *)) w-%offset%)
+ (f2cl-lib:fref h-%data% (ilo ilo) ((1 ldh) (1 *)) h-%offset%))
+ (go end_label)))
+ (setf nmin
+ (multiple-value-bind (ret-val var-0 var-1 var-2 var-3 var-4
+ var-5 var-6)
+ (ilaenv 12 "ZHSEQR" (f2cl-lib:f2cl-// job compz) n ilo ihi lwork)
+ (declare (ignore var-0 var-1 var-2)) (when var-3 (setf n var-3))
+ (when var-4 (setf ilo var-4)) (when var-5 (setf ihi var-5))
+ (when var-6 (setf lwork var-6)) ret-val))
+ (setf nmin (max (the f2cl-lib:integer4 ntiny)
+ (the f2cl-lib:integer4 nmin)))
+ (cond
+ ((> n nmin)
+ (multiple-value-bind
+ (var-0 var-1 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)
+ (zlaqr0 wantt wantz n ilo ihi h ldh w ilo ihi z
+ ldz work lwork info)
+ (declare (ignore var-5 var-7 var-10 var-12))
+ (when var-0 (setf wantt var-0)) (when var-1 (setf wantz var-1))
+ (when var-2 (setf n var-2)) (when var-3 (setf ilo var-3))
+ (when var-4 (setf ihi var-4)) (when var-6 (setf ldh var-6))
+ (when var-8 (setf ilo var-8)) (when var-9 (setf ihi var-9))
+ (when var-11 (setf ldz var-11)) (when var-13 (setf lwork var-13))
+ (when var-14 (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)
+ (zlahqr wantt wantz n ilo ihi h ldh w ilo ihi z ldz info)
+ (declare (ignore var-5 var-7 var-10))
+ (when var-0 (setf wantt var-0))
+ (when var-1 (setf wantz var-1)) (when var-2 (setf n var-2))
+ (when var-3 (setf ilo var-3)) (when var-4 (setf ihi var-4))
+ (when var-6 (setf ldh var-6)) (when var-8 (setf ilo var-8))
+ (when var-9 (setf ihi var-9)) (when var-11 (setf ldz var-11))
+ (when var-12 (setf info var-12)))
+ (cond
+ ((> info 0) (setf kbot info)
+ (cond
+ ((>= n nl)
+ (multiple-value-bind
+ (var-0 var-1 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)
+ (zlaqr0 wantt wantz n ilo kbot h ldh w ilo ihi z
+ ldz work lwork info)
+ (declare (ignore var-5 var-7 var-10 var-12))
+ (when var-0 (setf wantt var-0))
+ (when var-1 (setf wantz var-1))
+ (when var-2 (setf n var-2)) (when var-3 (setf ilo var-3))
+ (when var-4 (setf kbot var-4)) (when var-6 (setf ldh var-6))
+ (when var-8 (setf ilo var-8)) (when var-9 (setf ihi var-9))
+ (when var-11 (setf ldz var-11))
+ (when var-13 (setf lwork var-13))
+ (when var-14 (setf info var-14))))
+ (t
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (zlacpy "A" n n h ldh hl nl)
+ (declare (ignore var-0 var-3 var-5))
+ (when var-1 (setf n var-1)) (when var-2 (setf n var-2))
+ (when var-4 (setf ldh var-4)) (when var-6 (setf nl var-6)))
+ (setf (f2cl-lib:fref hl ((f2cl-lib:int-add n 1) n)
+ ((1 nl) (1 nl)))
+ zero)
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (zlaset "A" nl (f2cl-lib:int-sub nl n) zero zero
+ (f2cl-lib:array-slice hl f2cl-lib:complex16
+ (1 (f2cl-lib:int-add n 1)) ((1 nl) (1 nl)))
+ nl)
+ (declare (ignore var-0 var-2 var-5))
+ (when var-1 (setf nl var-1))
+ (when var-3 (setf zero var-3)) (when var-4 (setf zero var-4))
+ (when var-6 (setf nl var-6)))
+ (multiple-value-bind
+ (var-0 var-1 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)
+ (zlaqr0 wantt wantz nl ilo kbot hl nl w ilo ihi z
+ ldz workl nl info)
+ (declare (ignore var-5 var-7 var-10 var-12))
+ (when var-0 (setf wantt var-0))
+ (when var-1 (setf wantz var-1))
+ (when var-2 (setf nl var-2)) (when var-3 (setf ilo var-3))
+ (when var-4 (setf kbot var-4)) (when var-6 (setf nl var-6))
+ (when var-8 (setf ilo var-8)) (when var-9 (setf ihi var-9))
+ (when var-11 (setf ldz var-11)) (when var-13 (setf nl var-13))
+ (when var-14 (setf info var-14)))
+ (if (or wantt (/= info 0))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (zlacpy "A" n n hl nl h ldh)
+ (declare (ignore var-0 var-3 var-5))
+ (when var-1 (setf n var-1))
+ (when var-2 (setf n var-2))
+ (when var-4 (setf nl var-4))
+ (when var-6 (setf ldh var-6))))))))))
+ (if (and (or wantt (/= info 0)) (> n 2))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (zlaset "L" (f2cl-lib:int-sub n 2) (f2cl-lib:int-sub n 2) zero zero
+ (f2cl-lib:array-slice h-%data% f2cl-lib:complex16
+ (3 1) ((1 ldh) (1 *))
+ h-%offset%)
+ ldh)
+ (declare (ignore var-0 var-1 var-2 var-5))
+ (when var-3 (setf zero var-3))
+ (when var-4 (setf zero var-4))
+ (when var-6 (setf ldh var-6))))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (f2cl-lib:dcmplx
+ (max
+ (f2cl-lib:dble
+ (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n)))
+ (f2cl-lib:dble
+ (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)))
+ rzero))))
+ end_label
+ (return
+ (values job compz n ilo ihi nil ldh nil nil ldz nil lwork info)))
+ )))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -109647,7 +114602,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlacgv.f}
* =====================================================================
SUBROUTINE ZLACGV( N, X, INCX )
*
@@ -109692,10 +114647,41 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlacgv}
-
+(defun zlacgv (n x incx)
+ (declare (type (f2cl-lib:integer4) incx n)
+ (type (array f2cl-lib:complex16 (*)) x))
+ (f2cl-lib:with-multi-array-data
+ ((x f2cl-lib:complex16 x-%data% x-%offset%))
+ (prog
+ ((i 0) (ioff 0)) (declare (type (f2cl-lib:integer4) ioff i))
+ (cond
+ ((= incx 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%)
+ (coerce (f2cl-lib:dconjg
+ (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%))
+ 'f2cl-lib:complex16))
+ label10)))
+ (t (setf ioff 1)
+ (if (< incx 0)
+ (setf ioff
+ (f2cl-lib:int-sub 1
+ (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) incx))))
+ (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
+ ((> i n) nil)
+ (tagbody
+ (setf (f2cl-lib:fref x-%data% (ioff) ((1 *)) x-%offset%)
+ (coerce
+ (f2cl-lib:dconjg (f2cl-lib:fref x-%data% (ioff)
+ ((1 *)) x-%offset%))
+ 'f2cl-lib:complex16))
+ (setf ioff (f2cl-lib:int-add ioff incx)) label20))))
+ (go end_label) end_label (return (values nil nil nil)))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -109803,7 +114789,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlacpy.f}
* =====================================================================
SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB )
*
@@ -109862,10 +114848,68 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlacpy}
-
+(defun zlacpy (uplo m n a lda b ldb$)
+ (declare (type (simple-array character (*)) uplo)
+ (type (f2cl-lib:integer4) ldb$ lda n m)
+ (type (array f2cl-lib:complex16 (*)) b a))
+ (f2cl-lib:with-multi-array-data
+ ((a f2cl-lib:complex16 a-%data% a-%offset%)
+ (b f2cl-lib:complex16 b-%data% b-%offset%)
+ (uplo character uplo-%data% uplo-%offset%))
+ (prog ((i 0) (j 0))
+ (declare (type (f2cl-lib:integer4) j i))
+ (cond
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame uplo "U")
+ (declare (ignore var-1)) (when var-0 (setf uplo var-0)) ret-val)
+ (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 f2cl-lib:integer4 j)
+ (the f2cl-lib:integer4 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%))
+ label10))
+ label20)))
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame uplo "L")
+ (declare (ignore var-1)) (when var-0 (setf uplo var-0)) ret-val)
+ (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%))
+ label30))
+ label40)))
+ (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%))
+ label50))
+ label60))))
+ (go end_label)
+ end_label
+ (return (values uplo nil nil nil nil nil nil)))
+ ))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -109938,7 +114982,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zladiv.f}
* =====================================================================
COMPLEX*16 FUNCTION ZLADIV( X, Y )
*
@@ -109974,10 +115018,21 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zladiv}
-
+(defun zladiv (x y) (declare (type (f2cl-lib:complex16) y x))
+ (prog
+ ((zi 0.0d0) (zr 0.0d0) (zladiv #C(0.0d0 0.0d0)) (dble$ 0.0) (dimag$ 0.0))
+ (declare (type (double-float) zr zi) (type (f2cl-lib:complex16) zladiv)
+ (type (single-float) dimag$ dble$))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
+ (dladiv (f2cl-lib:dble x) (f2cl-lib:dimag x) (f2cl-lib:dble y)
+ (f2cl-lib:dimag y) zr zi)
+ (declare (ignore var-0 var-1 var-2 var-3)) (when var-4 (setf zr var-4))
+ (when var-5 (setf zi var-5)))
+ (setf zladiv (f2cl-lib:dcmplx zr zi)) (go end_label) end_label
+ (return (values zladiv nil nil))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -110166,7 +115221,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlahqr.f}
* =====================================================================
SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
$ IHIZ, Z, LDZ, INFO )
@@ -110543,10 +115598,589 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlahqr}
-
+(let*
+ ((itmax 30) (zero (coerce (f2cl-lib:cmplx 0.0d0 0.0d0) 'f2cl-lib:complex16))
+ (one (coerce (f2cl-lib:cmplx 1.0d0 0.0d0) 'f2cl-lib:complex16)) (rzero 0.0d0)
+ (rone 1.0d0) (half 0.5d0) (dat1 (f2cl-lib:f2cl/ 3.0d0 4.0d0)))
+ (declare (type (f2cl-lib:integer4 30 30) itmax)
+ (type (f2cl-lib:complex16) zero) (type (f2cl-lib:complex16) one)
+ (type (double-float 0.0d0 0.0d0) rzero)
+ (type (double-float 1.0d0 1.0d0) rone) (type (double-float 0.5d0 0.5d0) half)
+ (type (double-float) dat1) (ignorable itmax zero one rzero rone half dat1))
+ (defun zlahqr (wantt wantz n ilo ihi h ldh w iloz ihiz z ldz info)
+ (declare (type f2cl-lib:logical wantz wantt)
+ (type (f2cl-lib:integer4) info ldz ihiz iloz ldh ihi ilo n)
+ (type (array f2cl-lib:complex16 (*)) z w h))
+ (f2cl-lib:with-multi-array-data
+ ((h f2cl-lib:complex16 h-%data% h-%offset%)
+ (w f2cl-lib:complex16 w-%data% w-%offset%)
+ (z f2cl-lib:complex16 z-%data% z-%offset%))
+ (labels
+ ((cabs1 (cdum)
+ (+ (abs (f2cl-lib:dble cdum)) (abs (f2cl-lib:dimag cdum)))))
+ (declare
+ (ftype (function (f2cl-lib:complex16)
+ (values double-float &rest t)) cabs1))
+ (prog
+ ((v (make-array 2 :element-type 'f2cl-lib:complex16)) (i 0) (i1 0)
+ (i2 0)
+ (its 0) (j 0) (jhi 0) (jlo 0) (k 0) (l 0) (m 0) (nh 0) (nz 0)
+ (aa 0.0d0)
+ (ab 0.0d0) (ba 0.0d0) (bb 0.0d0) (h10 0.0d0) (h21 0.0d0)
+ (rtemp 0.0d0)
+ (s 0.0d0) (safmax 0.0d0) (safmin 0.0d0) (smlnum 0.0d0)
+ (sx 0.0d0) (t2 0.0d0)
+ (tst 0.0d0) (ulp 0.0d0) (cdum #C(0.0d0 0.0d0)) (h11 #C(0.0d0 0.0d0))
+ (h11s #C(0.0d0 0.0d0)) (h22 #C(0.0d0 0.0d0)) (sc #C(0.0d0 0.0d0))
+ (sum #C(0.0d0 0.0d0)) (t$ #C(0.0d0 0.0d0)) (t1 #C(0.0d0 0.0d0))
+ (temp #C(0.0d0 0.0d0)) (u #C(0.0d0 0.0d0)) (v2 #C(0.0d0 0.0d0))
+ (x #C(0.0d0 0.0d0)) (y #C(0.0d0 0.0d0)) (dconjg$ 0.0))
+ (declare (type (array f2cl-lib:complex16 (2)) v)
+ (type (f2cl-lib:integer4) nz nh m l k jlo jhi j its i2 i1 i)
+ (type (double-float)
+ ulp tst t2 sx smlnum safmin safmax s rtemp h21 h10 bb
+ ba ab aa)
+ (type (f2cl-lib:complex16)
+ y x v2 u temp t1 t$ sum sc h22 h11s h11 cdum)
+ (type (single-float) dconjg$))
+ (setf info 0) (if (= n 0) (go end_label))
+ (cond
+ ((= ilo ihi)
+ (setf (f2cl-lib:fref w-%data% (ilo) ((1 *)) w-%offset%)
+ (f2cl-lib:fref h-%data% (ilo ilo) ((1 ldh) (1 *)) h-%offset%))
+ (go end_label)))
+ (f2cl-lib:fdo (j ilo (f2cl-lib:int-add j 1))
+ ((> j
+ (f2cl-lib:int-add ihi (f2cl-lib:int-sub 3)))
+ nil)
+ (tagbody
+ (setf
+ (f2cl-lib:fref h-%data% ((f2cl-lib:int-add j 2) j)
+ ((1 ldh) (1 *))
+ h-%offset%)
+ zero)
+ (setf
+ (f2cl-lib:fref h-%data% ((f2cl-lib:int-add j 3) j)
+ ((1 ldh) (1 *))
+ h-%offset%)
+ zero)
+ label10))
+ (if (<= ilo (f2cl-lib:int-sub ihi 2))
+ (setf
+ (f2cl-lib:fref h-%data%
+ (ihi (f2cl-lib:int-sub ihi 2)) ((1 ldh) (1 *))
+ h-%offset%)
+ zero))
+ (cond (wantt (setf jlo 1) (setf jhi n))
+ (t (setf jlo ilo) (setf jhi ihi)))
+ (f2cl-lib:fdo (i (f2cl-lib:int-add ilo 1) (f2cl-lib:int-add i 1))
+ ((> i ihi)
+ nil)
+ (tagbody
+ (cond
+ ((/=
+ (f2cl-lib:dimag
+ (f2cl-lib:fref h (i (f2cl-lib:int-add i
+ (f2cl-lib:int-sub 1)))
+ ((1 ldh) (1 *))))
+ rzero)
+ (setf sc
+ (/
+ (f2cl-lib:fref h-%data% (i (f2cl-lib:int-sub i 1))
+ ((1 ldh) (1 *))
+ h-%offset%)
+ (cabs1
+ (f2cl-lib:fref h-%data% (i (f2cl-lib:int-sub i 1))
+ ((1 ldh) (1 *))
+ h-%offset%))))
+ (setf sc (coerce (/ (f2cl-lib:dconjg sc) (abs sc))
+ 'f2cl-lib:complex16))
+ (setf
+ (f2cl-lib:fref h-%data% (i (f2cl-lib:int-sub i 1))
+ ((1 ldh) (1 *))
+ h-%offset%)
+ (coerce
+ (abs
+ (f2cl-lib:fref h-%data% (i (f2cl-lib:int-sub i 1))
+ ((1 ldh) (1 *))
+ h-%offset%))
+ 'f2cl-lib:complex16))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zscal (f2cl-lib:int-add (f2cl-lib:int-sub jhi i) 1) sc
+ (f2cl-lib:array-slice h-%data% f2cl-lib:complex16
+ (i i) ((1 ldh) (1 *))
+ h-%offset%)
+ ldh)
+ (declare (ignore var-0 var-2))
+ (when var-1 (setf sc var-1))
+ (when var-3 (setf ldh var-3)))
+ (zscal
+ (f2cl-lib:int-add
+ (f2cl-lib:int-sub
+ (min (the f2cl-lib:integer4 jhi)
+ (the f2cl-lib:integer4 (f2cl-lib:int-add i 1)))
+ jlo)
+ 1)
+ (f2cl-lib:dconjg sc)
+ (f2cl-lib:array-slice h-%data% f2cl-lib:complex16
+ (jlo i) ((1 ldh) (1 *))
+ h-%offset%)
+ 1)
+ (if wantz
+ (zscal (f2cl-lib:int-add (f2cl-lib:int-sub ihiz iloz) 1)
+ (f2cl-lib:dconjg sc)
+ (f2cl-lib:array-slice z-%data% f2cl-lib:complex16
+ (iloz i)
+ ((1 ldz) (1 *)) z-%offset%)
+ 1))))
+ label20))
+ (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 safmin (dlamch "SAFE MINIMUM")) (setf safmax (/ rone safmin))
+ (multiple-value-bind (var-0 var-1) (dlabad safmin safmax)
+ (declare (ignore))
+ (when var-0 (setf safmin var-0)) (when var-1 (setf safmax var-1)))
+ (setf ulp (dlamch "PRECISION"))
+ (setf smlnum (* safmin (/ (f2cl-lib:dble nh) ulp)))
+ (cond (wantt (setf i1 1) (setf i2 n))) (setf i ihi) label30
+ (if (< i ilo) (go label150)) (setf l ilo)
+ (f2cl-lib:fdo (its 0 (f2cl-lib:int-add its 1))
+ ((> its itmax) 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
+ (if
+ (<=
+ (cabs1
+ (f2cl-lib:fref h-%data% (k (f2cl-lib:int-sub k 1))
+ ((1 ldh) (1 *))
+ h-%offset%))
+ smlnum)
+ (go label50))
+ (setf tst
+ (+
+ (cabs1
+ (f2cl-lib:fref h-%data% ((f2cl-lib:int-sub k 1)
+ (f2cl-lib:int-sub k 1))
+ ((1 ldh) (1 *)) h-%offset%))
+ (cabs1 (f2cl-lib:fref h-%data% (k k) ((1 ldh) (1 *))
+ h-%offset%))))
+ (cond
+ ((= tst zero)
+ (if (>= (f2cl-lib:int-sub k 2) ilo)
+ (setf tst
+ (+ tst
+ (abs
+ (f2cl-lib:dble
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-sub k 1)
+ (f2cl-lib:int-sub k 2)) ((1 ldh) (1 *))
+ h-%offset%))))))
+ (if (<= (f2cl-lib:int-add k 1) ihi)
+ (setf tst
+ (+ tst
+ (abs
+ (f2cl-lib:dble
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1) k) ((1 ldh) (1 *))
+ h-%offset%))))))))
+ (cond
+ ((<=
+ (abs
+ (f2cl-lib:dble
+ (f2cl-lib:fref h
+ (k (f2cl-lib:int-add k (f2cl-lib:int-sub 1)))
+ ((1 ldh) (1 *)))))
+ (* ulp tst))
+ (setf ab
+ (max
+ (cabs1
+ (f2cl-lib:fref h-%data% (k (f2cl-lib:int-sub k 1))
+ ((1 ldh) (1 *))
+ h-%offset%))
+ (cabs1
+ (f2cl-lib:fref h-%data% ((f2cl-lib:int-sub k 1) k)
+ ((1 ldh) (1 *))
+ h-%offset%))))
+ (setf ba
+ (min
+ (cabs1
+ (f2cl-lib:fref h-%data% (k (f2cl-lib:int-sub k 1))
+ ((1 ldh) (1 *))
+ h-%offset%))
+ (cabs1
+ (f2cl-lib:fref h-%data% ((f2cl-lib:int-sub k 1) k)
+ ((1 ldh) (1 *))
+ h-%offset%))))
+ (setf aa
+ (max (cabs1 (f2cl-lib:fref h-%data% (k k) ((1 ldh)
+ (1 *)) h-%offset%))
+ (cabs1
+ (-
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-sub k 1) (f2cl-lib:int-sub k 1))
+ ((1 ldh) (1 *))
+ h-%offset%)
+ (f2cl-lib:fref h-%data% (k k) ((1 ldh) (1 *))
+ h-%offset%)))))
+ (setf bb
+ (min (cabs1 (f2cl-lib:fref h-%data% (k k) ((1 ldh)
+ (1 *)) h-%offset%))
+ (cabs1
+ (-
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-sub k 1) (f2cl-lib:int-sub k 1))
+ ((1 ldh) (1 *))
+ h-%offset%)
+ (f2cl-lib:fref h-%data% (k k) ((1 ldh) (1 *))
+ h-%offset%)))))
+ (setf s (+ aa ab))
+ (if (<= (* ba (/ ab s))
+ (max smlnum (* ulp (* bb (/ aa s)))))
+ (go label50))))
+ label40))
+ label50 (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 i) (go label140))
+ (cond ((not wantt) (setf i1 l) (setf i2 i)))
+ (cond
+ ((= its 10)
+ (setf s
+ (* dat1
+ (abs
+ (f2cl-lib:dble
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add l 1) l) ((1 ldh) (1 *))
+ h-%offset%)))))
+ (setf t$ (+ s (f2cl-lib:fref h-%data% (l l) ((1 ldh)
+ (1 *)) h-%offset%))))
+ ((= its 20)
+ (setf s
+ (* dat1
+ (abs
+ (f2cl-lib:dble
+ (f2cl-lib:fref h-%data%
+ (i (f2cl-lib:int-sub i 1)) ((1 ldh) (1 *))
+ h-%offset%)))))
+ (setf t$ (+ s (f2cl-lib:fref h-%data%
+ (i i) ((1 ldh) (1 *)) h-%offset%))))
+ (t (setf t$ (f2cl-lib:fref h-%data%
+ (i i) ((1 ldh) (1 *)) h-%offset%))
+ (setf u
+ (*
+ (f2cl-lib:fsqrt
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-sub i 1) i) ((1 ldh) (1 *))
+ h-%offset%))
+ (f2cl-lib:fsqrt
+ (f2cl-lib:fref h-%data%
+ (i (f2cl-lib:int-sub i 1)) ((1 ldh) (1 *))
+ h-%offset%))))
+ (setf s (cabs1 u))
+ (cond
+ ((/= s rzero)
+ (setf x
+ (* half
+ (-
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-sub i 1) (f2cl-lib:int-sub i 1))
+ ((1 ldh) (1 *))
+ h-%offset%)
+ t$)))
+ (setf sx (cabs1 x)) (setf s (max s (cabs1 x)))
+ (setf y (* s (f2cl-lib:fsqrt (+ (expt (/ x s) 2)
+ (expt (/ u s) 2)))))
+ (cond
+ ((> sx rzero)
+ (if
+ (<
+ (+ (* (f2cl-lib:dble (/ x sx)) (f2cl-lib:dble y))
+ (* (f2cl-lib:dimag (/ x sx)) (f2cl-lib:dimag y)))
+ rzero)
+ (setf y (- y)))))
+ (setf t$ (- t$ (* u (zladiv u (+ x y)))))))))
+ (f2cl-lib:fdo (m (f2cl-lib:int-add i (f2cl-lib:int-sub 1))
+ (f2cl-lib:int-add m (f2cl-lib:int-sub 1)))
+ ((> m (f2cl-lib:int-add l 1))
+ 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 h11s (- h11 t$))
+ (setf h21
+ (f2cl-lib:dble
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add m 1) m) ((1 ldh) (1 *))
+ h-%offset%)))
+ (setf s (+ (cabs1 h11s) (abs h21)))
+ (setf h11s (/ h11s s))
+ (setf h21 (/ h21 s))
+ (setf (f2cl-lib:fref v (1) ((1 2))) h11s)
+ (setf (f2cl-lib:fref v (2) ((1 2)))
+ (coerce h21 'f2cl-lib:complex16))
+ (setf h10
+ (f2cl-lib:dble
+ (f2cl-lib:fref h-%data%
+ (m (f2cl-lib:int-sub m 1)) ((1 ldh) (1 *))
+ h-%offset%)))
+ (if
+ (<= (* (abs h10) (abs h21))
+ (* ulp (* (cabs1 h11s) (+ (cabs1 h11) (cabs1 h22)))))
+ (go label70))
+ label60))
+ (setf h11
+ (f2cl-lib:fref h-%data% (l l) ((1 ldh) (1 *)) h-%offset%))
+ (setf h22
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add l 1) (f2cl-lib:int-add l 1))
+ ((1 ldh) (1 *)) h-%offset%))
+ (setf h11s (- h11 t$))
+ (setf h21
+ (f2cl-lib:dble
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add l 1) l) ((1 ldh) (1 *))
+ h-%offset%)))
+ (setf s (+ (cabs1 h11s) (abs h21))) (setf h11s (/ h11s s))
+ (setf h21 (/ h21 s))
+ (setf (f2cl-lib:fref v (1) ((1 2))) h11s)
+ (setf (f2cl-lib:fref v (2) ((1 2)))
+ (coerce h21 'f2cl-lib:complex16))
+ label70
+ (f2cl-lib:fdo (k m (f2cl-lib:int-add k 1))
+ ((> k
+ (f2cl-lib:int-add i (f2cl-lib:int-sub 1)))
+ nil)
+ (tagbody
+ (if (> k m)
+ (zcopy 2
+ (f2cl-lib:array-slice h-%data% f2cl-lib:complex16
+ (k (f2cl-lib:int-sub k 1)) ((1 ldh) (1 *)) h-%offset%)
+ 1 v 1))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
+ (zlarfg 2 (f2cl-lib:array-slice v f2cl-lib:complex16
+ (1) ((1 2)))
+ (f2cl-lib:array-slice v f2cl-lib:complex16
+ (2) ((1 2))) 1 t1)
+ (declare (ignore var-0 var-1 var-2 var-3))
+ (when var-4 (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 2))))
+ (setf
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1) (f2cl-lib:int-sub k 1))
+ ((1 ldh) (1 *)) h-%offset%)
+ zero)))
+ (setf v2 (f2cl-lib:fref v (2) ((1 2))))
+ (setf t2 (f2cl-lib:dble (* t1 v2)))
+ (f2cl-lib:fdo (j k (f2cl-lib:int-add j 1))
+ ((> j i2) nil)
+ (tagbody
+ (setf sum
+ (+
+ (* (f2cl-lib:dconjg t1)
+ (f2cl-lib:fref h-%data% (k j)
+ ((1 ldh) (1 *)) h-%offset%))
+ (* t2
+ (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))
+ (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 v2)))
+ label80))
+ (f2cl-lib:fdo (j i1 (f2cl-lib:int-add j 1))
+ ((> j
+ (min (the f2cl-lib:integer4 (f2cl-lib:int-add k 2))
+ (the f2cl-lib:integer4 i)))
+ nil)
+ (tagbody
+ (setf sum
+ (+ (* t1 (f2cl-lib:fref h-%data%
+ (j k) ((1 ldh) (1 *)) h-%offset%))
+ (* t2
+ (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))
+ (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 (f2cl-lib:dconjg v2))))
+ label90))
+ (cond
+ (wantz
+ (f2cl-lib:fdo (j iloz (f2cl-lib:int-add j 1))
+ ((> j ihiz) nil)
+ (tagbody
+ (setf sum
+ (+ (* t1 (f2cl-lib:fref z-%data%
+ (j k) ((1 ldz) (1 *)) z-%offset%))
+ (* t2
+ (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))
+ (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 (f2cl-lib:dconjg v2))))
+ label100))))
+ (cond
+ ((and (= k m) (> m l)) (setf temp (- one t1))
+ (setf temp (/ temp (abs temp)))
+ (setf
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add m 1) m) ((1 ldh) (1 *))
+ h-%offset%)
+ (coerce
+ (*
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add m 1) m) ((1 ldh) (1 *))
+ h-%offset%)
+ (f2cl-lib:dconjg temp))
+ 'f2cl-lib:complex16))
+ (if (<= (f2cl-lib:int-add m 2) i)
+ (setf
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add m 2) (f2cl-lib:int-add m 1))
+ ((1 ldh) (1 *)) h-%offset%)
+ (*
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add m 2)
+ (f2cl-lib:int-add m 1)) ((1 ldh) (1 *))
+ h-%offset%)
+ temp)))
+ (f2cl-lib:fdo (j m (f2cl-lib:int-add j 1))
+ ((> j i) nil)
+ (tagbody
+ (cond
+ ((/= j (f2cl-lib:int-add m 1))
+ (if (> i2 j)
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zscal (f2cl-lib:int-sub i2 j) temp
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16
+ (j (f2cl-lib:int-add j 1))
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh)
+ (declare (ignore var-0 var-2))
+ (when var-1 (setf temp var-1))
+ (when var-3 (setf ldh var-3))))
+ (zscal (f2cl-lib:int-sub j i1)
+ (f2cl-lib:dconjg temp)
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (i1 j)
+ ((1 ldh) (1 *)) h-%offset%)
+ 1)
+ (cond
+ (wantz
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zscal nz (f2cl-lib:dconjg temp)
+ (f2cl-lib:array-slice z-%data%
+ f2cl-lib:complex16 (iloz j)
+ ((1 ldz) (1 *)) z-%offset%)
+ 1)
+ (declare (ignore var-1 var-2 var-3))
+ (when var-0 (setf nz var-0)))))))
+ label110))))
+ label120))
+ (setf temp
+ (f2cl-lib:fref h-%data%
+ (i (f2cl-lib:int-sub i 1)) ((1 ldh) (1 *))
+ h-%offset%))
+ (cond
+ ((/= (f2cl-lib:dimag temp) rzero) (setf rtemp (abs temp))
+ (setf
+ (f2cl-lib:fref h-%data%
+ (i (f2cl-lib:int-sub i 1)) ((1 ldh) (1 *))
+ h-%offset%)
+ (coerce rtemp 'f2cl-lib:complex16))
+ (setf temp (/ temp rtemp))
+ (if (> i2 i)
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zscal (f2cl-lib:int-sub i2 i) (f2cl-lib:dconjg temp)
+ (f2cl-lib:array-slice h-%data% f2cl-lib:complex16
+ (i (f2cl-lib:int-add i 1)) ((1 ldh) (1 *)) h-%offset%)
+ ldh)
+ (declare (ignore var-0 var-1 var-2))
+ (when var-3 (setf ldh var-3))))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zscal (f2cl-lib:int-sub i i1) temp
+ (f2cl-lib:array-slice h-%data% f2cl-lib:complex16
+ (i1 i) ((1 ldh) (1 *))
+ h-%offset%)
+ 1)
+ (declare (ignore var-0 var-2 var-3))
+ (when var-1 (setf temp var-1)))
+ (cond
+ (wantz
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zscal nz temp
+ (f2cl-lib:array-slice z-%data% f2cl-lib:complex16
+ (iloz i)
+ ((1 ldz) (1 *)) z-%offset%)
+ 1)
+ (declare (ignore var-2 var-3))
+ (when var-0 (setf nz var-0))
+ (when var-1 (setf temp var-1)))))))
+ label130))
+ (setf info i) (go end_label) label140
+ (setf (f2cl-lib:fref w-%data% (i) ((1 *)) w-%offset%)
+ (f2cl-lib:fref h-%data% (i i) ((1 ldh) (1 *)) h-%offset%))
+ (setf i (f2cl-lib:int-sub l 1)) (go label30) label150 (go end_label)
+ end_label
+ (return
+ (values nil nil nil nil nil nil ldh nil nil nil nil nil info))))
+ )))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -110724,7 +116358,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlahr2.f}
* =====================================================================
SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
*
@@ -110874,10 +116508,326 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlahr2}
-
+(let*
+ ((zero (coerce (f2cl-lib:cmplx 0.0d0 0.0d0) 'f2cl-lib:complex16))
+ (one (coerce (f2cl-lib:cmplx 1.0d0 0.0d0) 'f2cl-lib:complex16)))
+ (declare (type (f2cl-lib:complex16) zero) (type (f2cl-lib:complex16) one)
+ (ignorable zero one))
+ (defun zlahr2 (n k nb a lda tau t$ ldt y ldy)
+ (declare (type (f2cl-lib:integer4) ldy ldt lda nb k n)
+ (type (array f2cl-lib:complex16 (*)) y t$ tau a))
+ (f2cl-lib:with-multi-array-data
+ ((a f2cl-lib:complex16 a-%data% a-%offset%)
+ (tau f2cl-lib:complex16 tau-%data% tau-%offset%)
+ (t$ f2cl-lib:complex16 t$-%data% t$-%offset%)
+ (y f2cl-lib:complex16 y-%data% y-%offset%))
+ (prog ((ei #C(0.0d0 0.0d0)) (i 0))
+ (declare (type (f2cl-lib:complex16) ei) (type (f2cl-lib:integer4) 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)
+ (zlacgv (f2cl-lib:int-sub i 1)
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ k i (f2cl-lib:int-sub 1)) 1) ((1 lda) (1 *))
+ a-%offset%)
+ 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)
+ (zgemv "NO TRANSPOSE"
+ (f2cl-lib:int-sub n k) (f2cl-lib:int-sub i 1)
+ (- one)
+ (f2cl-lib:array-slice y-%data% f2cl-lib:complex16
+ ((+ k 1) 1)
+ ((1 ldy) (1 nb)) y-%offset%)
+ ldy
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ k i (f2cl-lib:int-sub 1)) 1) ((1 lda) (1 *))
+ a-%offset%)
+ lda one
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ k 1) i)
+ ((1 lda) (1 *)) a-%offset%)
+ 1)
+ (declare (ignore var-0 var-1 var-2 var-3 var-4 var-6
+ var-9 var-10))
+ (when var-5 (setf ldy var-5))
+ (when var-7 (setf lda var-7))
+ (when var-8 (setf one var-8)))
+ (zlacgv (f2cl-lib:int-sub i 1)
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ k i (f2cl-lib:int-sub 1)) 1) ((1 lda) (1 *))
+ a-%offset%)
+ lda)
+ (zcopy (f2cl-lib:int-sub i 1)
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ k 1) i)
+ ((1 lda) (1 *)) a-%offset%)
+ 1
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16
+ (1 nb) ((1 ldt) (1 nb))
+ t$-%offset%)
+ 1)
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4
+ var-5 var-6 var-7)
+ (ztrmv "Lower" "Conjugate transpose" "UNIT"
+ (f2cl-lib:int-sub i 1)
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ k 1) 1)
+ ((1 lda) (1 *)) a-%offset%)
+ lda
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16 (1 nb)
+ ((1 ldt) (1 nb)) t$-%offset%)
+ 1)
+ (declare (ignore var-0 var-1 var-2 var-3 var-4
+ var-6 var-7))
+ (when var-5 (setf lda var-5)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (zgemv "Conjugate 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-%data% f2cl-lib:complex16
+ ((+ k i) 1)
+ ((1 lda) (1 *)) a-%offset%)
+ lda
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ k i) i)
+ ((1 lda) (1 *)) a-%offset%)
+ 1 one
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16 (1 nb)
+ ((1 ldt) (1 nb)) t$-%offset%)
+ 1)
+ (declare (ignore var-0 var-1 var-2 var-4 var-6
+ var-7 var-9 var-10))
+ (when var-3 (setf one var-3))
+ (when var-5 (setf lda var-5))
+ (when var-8 (setf one var-8)))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4
+ var-5 var-6 var-7)
+ (ztrmv "Upper" "Conjugate transpose" "NON-UNIT"
+ (f2cl-lib:int-sub i 1) t$
+ ldt
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16 (1 nb)
+ ((1 ldt) (1 nb)) t$-%offset%)
+ 1)
+ (declare (ignore var-0 var-1 var-2 var-3 var-4
+ var-6 var-7))
+ (when var-5 (setf ldt var-5)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (zgemv "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-%data% f2cl-lib:complex16
+ ((+ k i) 1)
+ ((1 lda) (1 *)) a-%offset%)
+ lda
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16 (1 nb)
+ ((1 ldt) (1 nb)) t$-%offset%)
+ 1 one
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ k i) i)
+ ((1 lda) (1 *)) a-%offset%)
+ 1)
+ (declare (ignore var-0 var-1 var-2 var-3 var-4 var-6
+ var-7 var-9 var-10))
+ (when var-5 (setf lda var-5))
+ (when var-8 (setf one var-8)))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4
+ var-5 var-6 var-7)
+ (ztrmv "Lower" "NO TRANSPOSE" "UNIT"
+ (f2cl-lib:int-sub i 1)
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ k 1) 1)
+ ((1 lda) (1 *)) a-%offset%)
+ lda
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16 (1 nb)
+ ((1 ldt) (1 nb)) t$-%offset%)
+ 1)
+ (declare (ignore var-0 var-1 var-2 var-3 var-4 var-6
+ var-7))
+ (when var-5 (setf lda var-5)))
+ (zaxpy (f2cl-lib:int-sub i 1) (- one)
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16
+ (1 nb) ((1 ldt) (1 nb))
+ t$-%offset%)
+ 1
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ k 1) i)
+ ((1 lda) (1 *)) a-%offset%)
+ 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)))
+ (zlarfg (f2cl-lib:int-add (f2cl-lib:int-sub n k i) 1)
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ k i) i)
+ ((1 lda) (1 *)) a-%offset%)
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((min (f2cl-lib:int-add k i 1) n) i) ((1 lda) (1 *))
+ a-%offset%)
+ 1
+ (f2cl-lib:array-slice tau-%data% f2cl-lib:complex16
+ (i) ((1 nb))
+ tau-%offset%))
+ (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)
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
+ var-9 var-10)
+ (zgemv "NO TRANSPOSE" (f2cl-lib:int-sub n k)
+ (f2cl-lib:int-add (f2cl-lib:int-sub n k i) 1) one
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ k 1) (f2cl-lib:int-add i 1)) ((1 lda) (1 *)) a-%offset%)
+ lda
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ k i) i)
+ ((1 lda) (1 *)) a-%offset%)
+ 1 zero
+ (f2cl-lib:array-slice y-%data% f2cl-lib:complex16
+ ((+ k 1) i)
+ ((1 ldy) (1 nb)) y-%offset%)
+ 1)
+ (declare (ignore var-0 var-1 var-2 var-4 var-6 var-7
+ var-9 var-10))
+ (when var-3 (setf one var-3)) (when var-5 (setf lda var-5))
+ (when var-8 (setf zero var-8)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
+ var-9 var-10)
+ (zgemv "Conjugate 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-%data% f2cl-lib:complex16
+ ((+ k i) 1)
+ ((1 lda) (1 *)) a-%offset%)
+ lda
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ k i) i)
+ ((1 lda) (1 *)) a-%offset%)
+ 1 zero
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16
+ (1 i) ((1 ldt) (1 nb))
+ t$-%offset%)
+ 1)
+ (declare (ignore var-0 var-1 var-2 var-4 var-6 var-7
+ var-9 var-10))
+ (when var-3 (setf one var-3)) (when var-5 (setf lda var-5))
+ (when var-8 (setf zero var-8)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
+ var-9 var-10)
+ (zgemv "NO TRANSPOSE" (f2cl-lib:int-sub n k)
+ (f2cl-lib:int-sub i 1) (- one)
+ (f2cl-lib:array-slice y-%data% f2cl-lib:complex16
+ ((+ k 1) 1)
+ ((1 ldy) (1 nb)) y-%offset%)
+ ldy
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16
+ (1 i) ((1 ldt) (1 nb))
+ t$-%offset%)
+ 1 one
+ (f2cl-lib:array-slice y-%data% f2cl-lib:complex16
+ ((+ k 1) i)
+ ((1 ldy) (1 nb)) y-%offset%)
+ 1)
+ (declare (ignore var-0 var-1 var-2 var-3 var-4 var-6
+ var-7 var-9 var-10))
+ (when var-5 (setf ldy var-5)) (when var-8 (setf one var-8)))
+ (zscal (f2cl-lib:int-sub n k)
+ (f2cl-lib:array-slice tau-%data% f2cl-lib:complex16
+ (i) ((1 nb))
+ tau-%offset%)
+ (f2cl-lib:array-slice y-%data% f2cl-lib:complex16
+ ((+ k 1) i)
+ ((1 ldy) (1 nb)) y-%offset%)
+ 1)
+ (zscal (f2cl-lib:int-sub i 1)
+ (- (f2cl-lib:fref tau-%data% (i) ((1 nb)) tau-%offset%))
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16
+ (1 i) ((1 ldt) (1 nb))
+ t$-%offset%)
+ 1)
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)
+ (ztrmv "Upper" "No Transpose" "NON-UNIT"
+ (f2cl-lib:int-sub i 1) t$ ldt
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16
+ (1 i) ((1 ldt) (1 nb))
+ t$-%offset%)
+ 1)
+ (declare (ignore var-0 var-1 var-2 var-3 var-4 var-6 var-7))
+ (when var-5 (setf ldt var-5)))
+ (setf (f2cl-lib:fref t$-%data% (i i) ((1 ldt) (1 nb))
+ t$-%offset%)
+ (f2cl-lib:fref tau-%data% (i) ((1 nb)) tau-%offset%))
+ label10))
+ (setf
+ (f2cl-lib:fref a-%data% ((f2cl-lib:int-add k nb) nb) ((1 lda) (1 *))
+ a-%offset%)
+ ei)
+ (zlacpy "ALL" k nb
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ (1 2) ((1 lda) (1 *))
+ a-%offset%)
+ lda y ldy)
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10)
+ (ztrmm "RIGHT" "Lower" "NO TRANSPOSE" "UNIT" k nb one
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16 ((+ k 1) 1)
+ ((1 lda) (1 *)) a-%offset%)
+ lda y ldy)
+ (declare (ignore var-0 var-1 var-2 var-3 var-7 var-9))
+ (when var-4 (setf k var-4)) (when var-5 (setf nb var-5))
+ (when var-6 (setf one var-6)) (when var-8 (setf lda var-8))
+ (when var-10 (setf ldy var-10)))
+ (if (> n (f2cl-lib:int-add k nb))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
+ var-10 var-11
+ var-12)
+ (zgemm "NO TRANSPOSE" "NO TRANSPOSE"
+ k nb (f2cl-lib:int-sub n k nb) one
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ (1 (f2cl-lib:int-add 2 nb)) ((1 lda) (1 *)) a-%offset%)
+ lda
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16 ((+ k 1 nb) 1)
+ ((1 lda) (1 *)) a-%offset%)
+ lda one y ldy)
+ (declare (ignore var-0 var-1 var-4 var-6 var-8 var-11))
+ (when var-2 (setf k var-2)) (when var-3 (setf nb var-3))
+ (when var-5 (setf one var-5)) (when var-7 (setf lda var-7))
+ (when var-9 (setf lda var-9)) (when var-10 (setf one var-10))
+ (when var-12 (setf ldy var-12))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10)
+ (ztrmm "RIGHT" "Upper" "NO TRANSPOSE" "NON-UNIT" k nb one
+ t$ ldt y ldy)
+ (declare (ignore var-0 var-1 var-2 var-3 var-7 var-9))
+ (when var-4 (setf k var-4)) (when var-5 (setf nb var-5))
+ (when var-6 (setf one var-6)) (when var-8 (setf ldt var-8))
+ (when var-10 (setf ldy var-10)))
+ (go end_label) end_label
+ (return (values nil k nb nil lda nil nil ldt nil ldy))))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -110993,7 +116943,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlange.f}
* =====================================================================
DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK )
*
@@ -111092,7 +117042,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlange}
(let* ((one 1.0) (zero 0.0))
@@ -111431,7 +117381,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlaqr0.f}
* =====================================================================
SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
$ IHIZ, Z, LDZ, WORK, LWORK, INFO )
@@ -111897,10 +117847,608 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlaqr0}
-
+(let*
+ ((ntiny 11) (kexnw 5) (kexsh 6) (wilk1 0.75d0)
+ (zero (coerce (f2cl-lib:cmplx 0.0d0 0.0d0) 'f2cl-lib:complex16))
+ (one (coerce (f2cl-lib:cmplx 1.0d0 0.0d0) 'f2cl-lib:complex16)) (two 2.0d0))
+ (declare (type (f2cl-lib:integer4 11 11) ntiny)
+ (type (f2cl-lib:integer4 5 5) kexnw) (type (f2cl-lib:integer4 6 6) kexsh)
+ (type (double-float 0.75d0 0.75d0) wilk1) (type (f2cl-lib:complex16) zero)
+ (type (f2cl-lib:complex16) one) (type (double-float 2.0d0 2.0d0) two)
+ (ignorable ntiny kexnw kexsh wilk1 zero one two))
+ (defun zlaqr0 (wantt wantz n ilo ihi h ldh w iloz ihiz z ldz work lwork info)
+ (declare (type f2cl-lib:logical wantz wantt)
+ (type (f2cl-lib:integer4) info lwork ldz ihiz iloz ldh ihi ilo n)
+ (type (array f2cl-lib:complex16 (*)) work z w h))
+ (f2cl-lib:with-multi-array-data
+ ((h f2cl-lib:complex16 h-%data% h-%offset%)
+ (w f2cl-lib:complex16 w-%data% w-%offset%)
+ (z f2cl-lib:complex16 z-%data% z-%offset%)
+ (work f2cl-lib:complex16 work-%data% work-%offset%))
+ (labels
+ ((cabs1 (cdum) (+ (abs (f2cl-lib:dble cdum))
+ (abs (f2cl-lib:dimag cdum)))))
+ (declare
+ (ftype (function (f2cl-lib:complex16)
+ (values double-float &rest t)) cabs1))
+ (prog
+ ((zdum (make-array 1 :element-type 'f2cl-lib:complex16))
+ (jbcmpz (make-array '(2) :element-type 'character
+ :initial-element #\space))
+ (sorted nil) (i 0) (inf 0) (it 0) (itmax 0) (k 0) (kacc22 0) (kbot 0)
+ (kdu 0) (ks 0) (kt 0) (ktop 0) (ku 0) (kv 0) (kwh 0) (kwtop 0)
+ (kwv 0)
+ (ld 0) (ls 0) (lwkopt 0) (ndec 0) (ndfl 0) (nh 0) (nho 0) (nibble 0)
+ (nmin 0) (ns 0) (nsmax 0) (nsr 0) (nve 0) (nw 0) (nwmax 0) (nwr 0)
+ (nwupbd 0) (s 0.0d0) (aa #C(0.0d0 0.0d0)) (bb #C(0.0d0 0.0d0))
+ (cc #C(0.0d0 0.0d0)) (cdum #C(0.0d0 0.0d0)) (dd #C(0.0d0 0.0d0))
+ (det #C(0.0d0 0.0d0)) (rtdisc #C(0.0d0 0.0d0)) (swap #C(0.0d0 0.0d0))
+ (tr2 #C(0.0d0 0.0d0)))
+ (declare (type (array f2cl-lib:complex16 (1)) zdum)
+ (type (simple-array character (2)) jbcmpz)
+ (type f2cl-lib:logical sorted)
+ (type (f2cl-lib:integer4) nwupbd nwr nwmax nw nve nsr nsmax ns
+ nmin nibble
+ nho nh ndfl ndec lwkopt ls ld kwv kwtop kwh kv ku ktop kt ks
+ kdu kbot
+ kacc22 k itmax it inf i)
+ (type (double-float) s)
+ (type (f2cl-lib:complex16) tr2 swap rtdisc det dd cdum cc bb aa))
+ (setf info 0)
+ (cond
+ ((= n 0)
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) one)
+ (go end_label)))
+ (cond
+ ((<= n ntiny) (setf lwkopt 1)
+ (if (/= lwork -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)
+ (zlahqr wantt wantz n ilo ihi h ldh w iloz ihiz z ldz info)
+ (declare
+ (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-7 var-8
+ var-9 var-10
+ var-11))
+ (setf ldh var-6) (setf info var-12))))
+ (t
+ (tagbody (setf info 0)
+ (cond
+ (wantt (f2cl-lib:fset-string
+ (f2cl-lib:fref-string jbcmpz (1 1)) "S"))
+ (t (f2cl-lib:fset-string
+ (f2cl-lib:fref-string jbcmpz (1 1)) "E")))
+ (cond
+ (wantz (f2cl-lib:fset-string
+ (f2cl-lib:fref-string jbcmpz (2 2)) "V"))
+ (t (f2cl-lib:fset-string
+ (f2cl-lib:fref-string jbcmpz (2 2)) "N")))
+ (setf nwr
+ (multiple-value-bind
+ (ret-val var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (ilaenv 13 "ZLAQR0" jbcmpz n ilo ihi lwork)
+ (declare (ignore var-0 var-1)) (when var-2 (setf jbcmpz var-2))
+ (when var-3 (setf n var-3)) (when var-4 (setf ilo var-4))
+ (when var-5 (setf ihi var-5))
+ (when var-6 (setf lwork var-6)) ret-val))
+ (setf nwr (max (the f2cl-lib:integer4 2)
+ (the f2cl-lib:integer4 nwr)))
+ (setf nwr
+ (min (f2cl-lib:int-add (f2cl-lib:int-sub ihi ilo) 1)
+ (the f2cl-lib:integer4 (truncate (- n 1) 3)) nwr))
+ (setf nsr
+ (multiple-value-bind
+ (ret-val var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (ilaenv 15 "ZLAQR0" jbcmpz n ilo ihi lwork)
+ (declare (ignore var-0 var-1)) (when var-2 (setf jbcmpz var-2))
+ (when var-3 (setf n var-3)) (when var-4 (setf ilo var-4))
+ (when var-5 (setf ihi var-5))
+ (when var-6 (setf lwork var-6)) ret-val))
+ (setf nsr
+ (min nsr (the f2cl-lib:integer4 (truncate (+ n 6) 9))
+ (f2cl-lib:int-sub ihi ilo)))
+ (setf nsr
+ (max (the f2cl-lib:integer4 2)
+ (the f2cl-lib:integer4 (f2cl-lib:int-sub nsr (mod nsr 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 var-13 var-14 var-15 var-16 var-17 var-18 var-19
+ var-20
+ var-21 var-22 var-23 var-24)
+ (zlaqr3 wantt wantz n ilo ihi (f2cl-lib:int-add nwr 1) h
+ ldh iloz ihiz z
+ ldz ls ld w h ldh n h ldh n h ldh work -1)
+ (declare
+ (ignore var-5 var-6 var-10 var-14 var-15 var-18 var-21
+ var-23 var-24))
+ (when var-0 (setf wantt var-0)) (when var-1 (setf wantz var-1))
+ (when var-2 (setf n var-2)) (when var-3 (setf ilo var-3))
+ (when var-4 (setf ihi var-4)) (when var-7 (setf ldh var-7))
+ (when var-8 (setf iloz var-8)) (when var-9 (setf ihiz var-9))
+ (when var-11 (setf ldz var-11)) (when var-12 (setf ls var-12))
+ (when var-13 (setf ld var-13)) (when var-16 (setf ldh var-16))
+ (when var-17 (setf n var-17)) (when var-19 (setf ldh var-19))
+ (when var-20 (setf n var-20)) (when var-22 (setf ldh var-22)))
+ (setf lwkopt
+ (max (the f2cl-lib:integer4 (truncate (* 3 nsr) 2))
+ (f2cl-lib:int (f2cl-lib:fref work-%data% (1) ((1 *))
+ work-%offset%))))
+ (cond
+ ((= lwork (f2cl-lib:int-sub 1))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (f2cl-lib:dcmplx lwkopt 0))
+ (go end_label)))
+ (setf nmin
+ (multiple-value-bind
+ (ret-val var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (ilaenv 12 "ZLAQR0" jbcmpz n ilo ihi lwork)
+ (declare (ignore var-0 var-1)) (when var-2 (setf jbcmpz var-2))
+ (when var-3 (setf n var-3)) (when var-4 (setf ilo var-4))
+ (when var-5 (setf ihi var-5))
+ (when var-6 (setf lwork var-6)) ret-val))
+ (setf nmin
+ (max (the f2cl-lib:integer4 ntiny) (the f2cl-lib:integer4 nmin)))
+ (setf nibble
+ (multiple-value-bind
+ (ret-val var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (ilaenv 14 "ZLAQR0" jbcmpz n ilo ihi lwork)
+ (declare (ignore var-0 var-1)) (when var-2 (setf jbcmpz var-2))
+ (when var-3 (setf n var-3)) (when var-4 (setf ilo var-4))
+ (when var-5 (setf ihi var-5))
+ (when var-6 (setf lwork var-6)) ret-val))
+ (setf nibble
+ (max (the f2cl-lib:integer4 0) (the f2cl-lib:integer4 nibble)))
+ (setf kacc22
+ (multiple-value-bind
+ (ret-val var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (ilaenv 16 "ZLAQR0" jbcmpz n ilo ihi lwork)
+ (declare (ignore var-0 var-1)) (when var-2 (setf jbcmpz var-2))
+ (when var-3 (setf n var-3)) (when var-4 (setf ilo var-4))
+ (when var-5 (setf ihi var-5))
+ (when var-6 (setf lwork var-6)) ret-val))
+ (setf kacc22
+ (max (the f2cl-lib:integer4 0) (the f2cl-lib:integer4 kacc22)))
+ (setf kacc22
+ (min (the f2cl-lib:integer4 2) (the f2cl-lib:integer4 kacc22)))
+ (setf nwmax
+ (min (the f2cl-lib:integer4 (truncate (- n 1) 3))
+ (the f2cl-lib:integer4 (truncate lwork 2))))
+ (setf nw nwmax)
+ (setf nsmax
+ (min (the f2cl-lib:integer4 (truncate (+ n 6) 9))
+ (the f2cl-lib:integer4 (truncate (* 2 lwork) 3))))
+ (setf nsmax (f2cl-lib:int-sub nsmax (mod nsmax 2))) (setf ndfl 1)
+ (setf itmax
+ (f2cl-lib:int-mul
+ (max (the f2cl-lib:integer4 30)
+ (the f2cl-lib:integer4 (f2cl-lib:int-mul 2 kexsh)))
+ (max (the f2cl-lib:integer4 10)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add (f2cl-lib:int-sub ihi ilo) 1)))))
+ (setf kbot ihi)
+ (f2cl-lib:fdo (it 1 (f2cl-lib:int-add it 1))
+ ((> it itmax) nil)
+ (tagbody
+ (if (< kbot ilo) (go label80))
+ (f2cl-lib:fdo (k kbot
+ (f2cl-lib:int-add k (f2cl-lib:int-sub 1)))
+ ((> k
+ (f2cl-lib:int-add ilo 1))
+ nil)
+ (tagbody
+ (if
+ (=
+ (f2cl-lib:fref h-%data% (k
+ (f2cl-lib:int-sub k 1)) ((1 ldh) (1 *))
+ h-%offset%)
+ zero)
+ (go label20))
+ label10))
+ (setf k ilo) label20 (setf ktop k)
+ (setf nh (f2cl-lib:int-add
+ (f2cl-lib:int-sub kbot ktop) 1))
+ (setf nwupbd
+ (min (the f2cl-lib:integer4 nh)
+ (the f2cl-lib:integer4 nwmax)))
+ (cond
+ ((< ndfl kexnw)
+ (setf nw
+ (min (the f2cl-lib:integer4 nwupbd)
+ (the f2cl-lib:integer4 nwr))))
+ (t
+ (setf nw
+ (min (the f2cl-lib:integer4 nwupbd)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-mul 2 nw))))))
+ (cond
+ ((< nw nwmax)
+ (cond ((>= nw (f2cl-lib:int-add nh
+ (f2cl-lib:int-sub 1))) (setf nw nh))
+ (t (setf kwtop (f2cl-lib:int-add
+ (f2cl-lib:int-sub kbot nw) 1))
+ (if
+ (>
+ (cabs1
+ (f2cl-lib:fref h-%data% (kwtop
+ (f2cl-lib:int-sub kwtop 1))
+ ((1 ldh) (1 *)) h-%offset%))
+ (cabs1
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-sub kwtop 1)
+ (f2cl-lib:int-sub kwtop 2))
+ ((1 ldh) (1 *)) h-%offset%)))
+ (setf nw (f2cl-lib:int-add nw 1)))))))
+ (cond ((< ndfl kexnw) (setf ndec -1))
+ ((or (>= ndec 0) (>= nw nwupbd))
+ (setf ndec (f2cl-lib:int-add ndec 1))
+ (if (< (f2cl-lib:int-sub nw ndec) 2) (setf ndec 0))
+ (setf nw (f2cl-lib:int-sub nw ndec))))
+ (setf kv (f2cl-lib:int-add
+ (f2cl-lib:int-sub n nw) 1))
+ (setf kt (f2cl-lib:int-add nw 1))
+ (setf nho (f2cl-lib:int-add
+ (f2cl-lib:int-sub n nw 1 kt) 1))
+ (setf kwv (f2cl-lib:int-add nw 2))
+ (setf nve
+ (f2cl-lib:int-add (f2cl-lib:int-sub n nw kwv) 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)
+ (zlaqr3 wantt wantz n ktop kbot nw h ldh iloz
+ ihiz z ldz ls ld w
+ (f2cl-lib:array-slice h-%data% f2cl-lib:complex16
+ (kv 1)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh nho
+ (f2cl-lib:array-slice h-%data% f2cl-lib:complex16
+ (kv kt)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh nve
+ (f2cl-lib:array-slice h-%data% f2cl-lib:complex16
+ (kwv 1)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh work lwork)
+ (declare (ignore var-6 var-10 var-14 var-15
+ var-18 var-21 var-23))
+ (when var-0 (setf wantt var-0))
+ (when var-1 (setf wantz var-1))
+ (when var-2 (setf n var-2))
+ (when var-3 (setf ktop var-3))
+ (when var-4 (setf kbot var-4))
+ (when var-5 (setf nw var-5))
+ (when var-7 (setf ldh var-7))
+ (when var-8 (setf iloz var-8))
+ (when var-9 (setf ihiz var-9))
+ (when var-11 (setf ldz var-11))
+ (when var-12 (setf ls var-12))
+ (when var-13 (setf ld var-13))
+ (when var-16 (setf ldh var-16))
+ (when var-17 (setf nho var-17))
+ (when var-19 (setf ldh var-19))
+ (when var-20 (setf nve var-20))
+ (when var-22 (setf ldh var-22))
+ (when var-24 (setf lwork var-24)))
+ (setf kbot (f2cl-lib:int-sub kbot ld))
+ (setf ks (f2cl-lib:int-add
+ (f2cl-lib:int-sub kbot ls) 1))
+ (cond
+ ((or (= ld 0)
+ (and (<= (f2cl-lib:int-mul 100 ld)
+ (f2cl-lib:int-mul nw nibble))
+ (> (f2cl-lib:int-add kbot
+ (f2cl-lib:int-sub ktop) 1)
+ (min (the f2cl-lib:integer4 nmin)
+ (the f2cl-lib:integer4 nwmax)))))
+ (setf ns
+ (min (the f2cl-lib:integer4 nsmax)
+ (the f2cl-lib:integer4 nsr)
+ (the f2cl-lib:integer4
+ (max (the f2cl-lib:integer4 2)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-sub kbot ktop))))))
+ (setf ns (f2cl-lib:int-sub ns (mod ns 2)))
+ (cond
+ ((= (mod ndfl kexsh) 0)
+ (setf ks (f2cl-lib:int-add
+ (f2cl-lib:int-sub kbot ns) 1))
+ (f2cl-lib:fdo (i kbot (f2cl-lib:int-add i
+ (f2cl-lib:int-sub 2)))
+ ((> i
+ (f2cl-lib:int-add ks 1))
+ nil)
+ (tagbody
+ (setf (f2cl-lib:fref w-%data% (i)
+ ((1 *)) w-%offset%)
+ (+ (f2cl-lib:fref h-%data% (i i)
+ ((1 ldh) (1 *)) h-%offset%)
+ (* wilk1
+ (cabs1
+ (f2cl-lib:fref h-%data%
+ (i (f2cl-lib:int-sub i 1))
+ ((1 ldh) (1 *)) h-%offset%)))))
+ (setf
+ (f2cl-lib:fref w-%data%
+ ((f2cl-lib:int-sub i 1)) ((1 *))
+ w-%offset%)
+ (f2cl-lib:fref w-%data% (i) ((1 *))
+ w-%offset%))
+ label30)))
+ (t
+ (cond
+ ((<= (f2cl-lib:int-add kbot
+ (f2cl-lib:int-sub ks) 1)
+ (f2cl-lib:f2cl/ ns 2))
+ (setf ks (f2cl-lib:int-add
+ (f2cl-lib:int-sub kbot ns) 1))
+ (setf kt (f2cl-lib:int-add
+ (f2cl-lib:int-sub n ns) 1))
+ (zlacpy "A" ns ns
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (ks ks)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (kt 1)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh)
+ (cond
+ ((> ns nmin)
+ (multiple-value-bind
+ (var-0 var-1 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)
+ (zlaqr4 f2cl-lib:%false% f2cl-lib:%false%
+ ns 1 ns
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (kt 1)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh
+ (f2cl-lib:array-slice w-%data%
+ f2cl-lib:complex16 (ks) ((1 *))
+ w-%offset%)
+ 1 1 zdum 1 work lwork inf)
+ (declare
+ (ignore var-0 var-1 var-3 var-5 var-7
+ var-8 var-9 var-10 var-11
+ var-12))
+ (when var-2 (setf ns var-2))
+ (when var-4 (setf ns var-4))
+ (when var-6 (setf ldh var-6))
+ (when var-13 (setf lwork var-13))
+ (when var-14 (setf inf 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)
+ (zlahqr f2cl-lib:%false% f2cl-lib:%false%
+ ns 1 ns
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (kt 1)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh
+ (f2cl-lib:array-slice w-%data%
+ f2cl-lib:complex16 (ks) ((1 *))
+ w-%offset%)
+ 1 1 zdum 1 inf)
+ (declare
+ (ignore var-0 var-1 var-2 var-3 var-4
+ var-5 var-7 var-8 var-9
+ var-10 var-11))
+ (setf ldh var-6) (setf inf var-12))))
+ (setf ks (f2cl-lib:int-add ks inf))
+ (cond
+ ((>= ks kbot)
+ (setf s
+ (+
+ (cabs1
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-sub kbot 1)
+ (f2cl-lib:int-sub kbot 1))
+ ((1 ldh) (1 *)) h-%offset%))
+ (cabs1
+ (f2cl-lib:fref h-%data% (kbot
+ (f2cl-lib:int-sub kbot 1))
+ ((1 ldh) (1 *)) h-%offset%))
+ (cabs1
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-sub kbot 1) kbot)
+ ((1 ldh) (1 *)) h-%offset%))
+ (cabs1
+ (f2cl-lib:fref h-%data% (kbot kbot)
+ ((1 ldh) (1 *))
+ h-%offset%))))
+ (setf aa
+ (/
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-sub kbot 1)
+ (f2cl-lib:int-sub kbot 1))
+ ((1 ldh) (1 *)) h-%offset%)
+ s))
+ (setf cc
+ (/
+ (f2cl-lib:fref h-%data% (kbot
+ (f2cl-lib:int-sub kbot 1))
+ ((1 ldh) (1 *)) h-%offset%)
+ s))
+ (setf bb
+ (/
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-sub kbot 1) kbot)
+ ((1 ldh) (1 *)) h-%offset%)
+ s))
+ (setf dd
+ (/
+ (f2cl-lib:fref h-%data% (kbot kbot)
+ ((1 ldh) (1 *)) h-%offset%)
+ s))
+ (setf tr2 (/ (+ aa dd) two))
+ (setf det (- (* (- aa tr2) (- dd tr2))
+ (* bb cc)))
+ (setf rtdisc (f2cl-lib:fsqrt (- det)))
+ (setf
+ (f2cl-lib:fref w-%data%
+ ((f2cl-lib:int-sub kbot 1)) ((1 *))
+ w-%offset%)
+ (* (+ tr2 rtdisc) s))
+ (setf (f2cl-lib:fref w-%data% (kbot)
+ ((1 *)) w-%offset%)
+ (* (- tr2 rtdisc) s))
+ (setf ks (f2cl-lib:int-sub kbot 1))))))
+ (cond
+ ((> (f2cl-lib:int-add kbot
+ (f2cl-lib:int-sub ks) 1) ns)
+ (tagbody (setf sorted f2cl-lib:%false%)
+ (f2cl-lib:fdo (k kbot
+ (f2cl-lib:int-add k (f2cl-lib:int-sub 1)))
+ ((>
+ k (f2cl-lib:int-add ks 1))
+ nil)
+ (tagbody (if sorted (go label60))
+ (setf sorted f2cl-lib:%true%)
+ (f2cl-lib:fdo (i ks
+ (f2cl-lib:int-add i 1))
+ ((> i
+ (f2cl-lib:int-add k
+ (f2cl-lib:int-sub 1)))
+ nil)
+ (tagbody
+ (cond
+ ((< (cabs1 (f2cl-lib:fref w (i)
+ ((1 *))))
+ (cabs1 (f2cl-lib:fref w
+ ((f2cl-lib:int-add i 1))
+ ((1 *)))))
+ (setf sorted f2cl-lib:%false%)
+ (setf swap
+ (f2cl-lib:fref w-%data% (i)
+ ((1 *)) w-%offset%))
+ (setf
+ (f2cl-lib:fref w-%data% (i)
+ ((1 *)) w-%offset%)
+ (f2cl-lib:fref w-%data%
+ ((f2cl-lib:int-add i 1))
+ ((1 *))
+ w-%offset%))
+ (setf
+ (f2cl-lib:fref w-%data%
+ ((f2cl-lib:int-add i 1))
+ ((1 *))
+ w-%offset%)
+ swap)))
+ label40))
+ label50))
+ label60)))))
+ (cond
+ ((= (f2cl-lib:int-add kbot
+ (f2cl-lib:int-sub ks) 1) 2)
+ (cond
+ ((<
+ (cabs1
+ (+ (f2cl-lib:fref w (kbot) ((1 *)))
+ (- (f2cl-lib:fref h (kbot kbot) ((1 ldh)
+ (1 *))))))
+ (cabs1
+ (+
+ (f2cl-lib:fref w ((f2cl-lib:int-add kbot
+ (f2cl-lib:int-sub 1)))
+ ((1 *)))
+ (- (f2cl-lib:fref h (kbot kbot) ((1 ldh)
+ (1 *)))))))
+ (setf
+ (f2cl-lib:fref w-%data%
+ ((f2cl-lib:int-sub kbot 1)) ((1 *))
+ w-%offset%)
+ (f2cl-lib:fref w-%data% (kbot) ((1 *))
+ w-%offset%)))
+ (t
+ (setf (f2cl-lib:fref w-%data% (kbot) ((1 *))
+ w-%offset%)
+ (f2cl-lib:fref w-%data%
+ ((f2cl-lib:int-sub kbot 1)) ((1 *))
+ w-%offset%))))))
+ (setf ns
+ (min (the f2cl-lib:integer4 ns)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add
+ (f2cl-lib:int-sub kbot ks) 1))))
+ (setf ns (f2cl-lib:int-sub ns (mod ns 2)))
+ (setf ks (f2cl-lib:int-add
+ (f2cl-lib:int-sub kbot ns) 1))
+ (setf kdu (f2cl-lib:int-sub
+ (f2cl-lib:int-mul 3 ns) 3))
+ (setf ku (f2cl-lib:int-add
+ (f2cl-lib:int-sub n kdu) 1))
+ (setf kwh (f2cl-lib:int-add kdu 1))
+ (setf nho
+ (f2cl-lib:int-add
+ (f2cl-lib:int-sub (f2cl-lib:int-add
+ (f2cl-lib:int-sub n kdu) 1) 4
+ (f2cl-lib:int-add kdu 1))
+ 1))
+ (setf kwv (f2cl-lib:int-add kdu 4))
+ (setf nve (f2cl-lib:int-add
+ (f2cl-lib:int-sub n kdu kwv) 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)
+ (zlaqr5 wantt wantz kacc22 n ktop kbot ns
+ (f2cl-lib:array-slice w-%data%
+ f2cl-lib:complex16 (ks) ((1 *))
+ w-%offset%)
+ h ldh iloz ihiz z ldz work 3
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (ku 1)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh nve
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (kwv 1)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh nho
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (ku kwh)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh)
+ (declare
+ (ignore var-7 var-8 var-12 var-14 var-15
+ var-16 var-19 var-22))
+ (when var-0 (setf wantt var-0))
+ (when var-1 (setf wantz var-1))
+ (when var-2 (setf kacc22 var-2))
+ (when var-3 (setf n var-3))
+ (when var-4 (setf ktop var-4))
+ (when var-5 (setf kbot var-5))
+ (when var-6 (setf ns var-6))
+ (when var-9 (setf ldh var-9))
+ (when var-10 (setf iloz var-10))
+ (when var-11 (setf ihiz var-11))
+ (when var-13 (setf ldz var-13))
+ (when var-17 (setf ldh var-17))
+ (when var-18 (setf nve var-18))
+ (when var-20 (setf ldh var-20))
+ (when var-21 (setf nho var-21))
+ (when var-23 (setf ldh var-23)))))
+ (cond ((> ld 0) (setf ndfl 1))
+ (t (setf ndfl (f2cl-lib:int-add ndfl 1))))
+ label70))
+ (setf info kbot) label80)))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (f2cl-lib:dcmplx lwkopt 0))
+ end_label
+ (return
+ (values wantt wantz n ilo ihi nil ldh nil iloz ihiz nil ldz nil lwork
+ info)))))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -112011,7 +118559,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlaqr1.f}
* =====================================================================
SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V )
*
@@ -112079,10 +118627,108 @@ Man Page Details
END IF
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlaqr1}
-
+(let*
+ ((zero (coerce (f2cl-lib:cmplx 0.0d0 0.0d0) 'f2cl-lib:complex16))
+ (rzero 0.0d0))
+ (declare (type (f2cl-lib:complex16) zero)
+ (type (double-float 0.0d0 0.0d0) rzero) (ignorable zero rzero))
+ (defun zlaqr1 (n h ldh s1 s2 v)
+ (declare (type (f2cl-lib:integer4) ldh n)
+ (type (array f2cl-lib:complex16 (*)) v h) (type (f2cl-lib:complex16) s2 s1))
+ (f2cl-lib:with-multi-array-data
+ ((h f2cl-lib:complex16 h-%data% h-%offset%)
+ (v f2cl-lib:complex16 v-%data% v-%offset%))
+ (labels
+ ((cabs1 (cdum) (+ (abs (f2cl-lib:dble cdum))
+ (abs (f2cl-lib:dimag cdum)))))
+ (declare
+ (ftype (function (f2cl-lib:complex16)
+ (values double-float &rest t)) cabs1))
+ (prog
+ ((s 0.0d0) (cdum #C(0.0d0 0.0d0)) (h21s #C(0.0d0 0.0d0))
+ (h31s #C(0.0d0 0.0d0)))
+ (declare (type (double-float) s)
+ (type (f2cl-lib:complex16) h31s h21s cdum))
+ (cond
+ ((= n 2)
+ (setf s
+ (+
+ (cabs1 (- (f2cl-lib:fref h-%data% (1 1) ((1 ldh) (1 *))
+ h-%offset%) s2))
+ (cabs1 (f2cl-lib:fref h-%data% (2 1) ((1 ldh) (1 *))
+ h-%offset%))))
+ (cond
+ ((= s rzero)
+ (setf (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%) zero)
+ (setf (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%) zero))
+ (t
+ (setf h21s
+ (/ (f2cl-lib:fref h-%data% (2 1) ((1 ldh) (1 *)) h-%offset%) s))
+ (setf (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)
+ (+ (* h21s (f2cl-lib:fref h-%data% (1 2) ((1 ldh) (1 *))
+ h-%offset%))
+ (* (- (f2cl-lib:fref h-%data% (1 1) ((1 ldh) (1 *))
+ h-%offset%) s1)
+ (/ (- (f2cl-lib:fref h-%data% (1 1) ((1 ldh) (1 *))
+ h-%offset%) s2)
+ s))))
+ (setf (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)
+ (* h21s
+ (-
+ (+ (f2cl-lib:fref h-%data% (1 1) ((1 ldh) (1 *)) h-%offset%)
+ (f2cl-lib:fref h-%data% (2 2) ((1 ldh) (1 *)) h-%offset%))
+ s1 s2))))))
+ (t
+ (setf s
+ (+
+ (cabs1
+ (- (f2cl-lib:fref h-%data% (1 1) ((1 ldh) (1 *)) h-%offset%) s2))
+ (cabs1 (f2cl-lib:fref h-%data% (2 1) ((1 ldh) (1 *)) h-%offset%))
+ (cabs1
+ (f2cl-lib:fref h-%data% (3 1) ((1 ldh) (1 *)) h-%offset%))))
+ (cond
+ ((= s zero)
+ (setf (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%) zero)
+ (setf (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%) zero)
+ (setf (f2cl-lib:fref v-%data% (3) ((1 *)) v-%offset%) zero))
+ (t
+ (setf h21s
+ (/ (f2cl-lib:fref h-%data% (2 1) ((1 ldh) (1 *)) h-%offset%) s))
+ (setf h31s
+ (/ (f2cl-lib:fref h-%data% (3 1) ((1 ldh) (1 *)) h-%offset%) s))
+ (setf (f2cl-lib:fref v-%data% (1) ((1 *)) v-%offset%)
+ (+
+ (* (- (f2cl-lib:fref h-%data% (1 1) ((1 ldh) (1 *))
+ h-%offset%) s1)
+ (/ (- (f2cl-lib:fref h-%data% (1 1) ((1 ldh) (1 *))
+ h-%offset%) s2)
+ s))
+ (* (f2cl-lib:fref h-%data% (1 2) ((1 ldh) (1 *)) h-%offset%)
+ h21s)
+ (* (f2cl-lib:fref h-%data% (1 3) ((1 ldh) (1 *)) h-%offset%)
+ h31s)))
+ (setf (f2cl-lib:fref v-%data% (2) ((1 *)) v-%offset%)
+ (+
+ (* h21s
+ (-
+ (+ (f2cl-lib:fref h-%data% (1 1) ((1 ldh) (1 *)) h-%offset%)
+ (f2cl-lib:fref h-%data% (2 2) ((1 ldh) (1 *)) h-%offset%))
+ s1 s2))
+ (* (f2cl-lib:fref h-%data% (2 3) ((1 ldh) (1 *)) h-%offset%)
+ h31s)))
+ (setf (f2cl-lib:fref v-%data% (3) ((1 *)) v-%offset%)
+ (+
+ (* h31s
+ (-
+ (+ (f2cl-lib:fref h-%data% (1 1) ((1 ldh) (1 *)) h-%offset%)
+ (f2cl-lib:fref h-%data% (3 3) ((1 ldh) (1 *)) h-%offset%))
+ s1 s2))
+ (* h21s
+ (f2cl-lib:fref h-%data% (3 2) ((1 ldh) (1 *)) h-%offset%))))))))
+ end_label (return (values nil nil nil nil nil nil)))))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -112333,7 +118979,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlaqr2.f}
* =====================================================================
SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
@@ -112635,10 +119281,454 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlaqr2}
-
+(let*
+ ((zero (coerce (f2cl-lib:cmplx 0.0d0 0.0d0) 'f2cl-lib:complex16))
+ (one (coerce (f2cl-lib:cmplx 1.0d0 0.0d0) 'f2cl-lib:complex16)) (rzero 0.0d0)
+ (rone 1.0d0))
+ (declare (type (f2cl-lib:complex16) zero) (type (f2cl-lib:complex16) one)
+ (type (double-float 0.0d0 0.0d0) rzero)
+ (type (double-float 1.0d0 1.0d0) rone) (ignorable zero one rzero rone))
+ (defun zlaqr2
+ (wantt wantz n ktop kbot nw h ldh iloz ihiz z ldz ns nd sh v ldv nh t$ ldt nv
+ wv ldwv work lwork)
+ (declare (type f2cl-lib:logical wantz wantt)
+ (type (f2cl-lib:integer4) lwork ldwv nv ldt nh ldv nd ns ldz ihiz iloz ldh
+ nw kbot ktop n)
+ (type (array f2cl-lib:complex16 (*)) work wv t$ v sh z h))
+ (f2cl-lib:with-multi-array-data
+ ((h f2cl-lib:complex16 h-%data% h-%offset%)
+ (z f2cl-lib:complex16 z-%data% z-%offset%)
+ (sh f2cl-lib:complex16 sh-%data% sh-%offset%)
+ (v f2cl-lib:complex16 v-%data% v-%offset%)
+ (t$ f2cl-lib:complex16 t$-%data% t$-%offset%)
+ (wv f2cl-lib:complex16 wv-%data% wv-%offset%)
+ (work f2cl-lib:complex16 work-%data% work-%offset%))
+ (labels
+ ((cabs1 (cdum)
+ (+ (abs (f2cl-lib:dble cdum)) (abs (f2cl-lib:dimag cdum)))))
+ (declare
+ (ftype (function (f2cl-lib:complex16)
+ (values double-float &rest t)) cabs1))
+ (prog
+ ((i 0) (ifst 0) (ilst 0) (info 0) (infqr 0) (j 0) (jw 0)
+ (kcol 0) (kln 0)
+ (knt 0) (krow 0) (kwtop 0) (ltop 0) (lwk1 0) (lwk2 0)
+ (lwkopt 0) (foo 0.0d0)
+ (safmax 0.0d0) (safmin 0.0d0) (smlnum 0.0d0) (ulp 0.0d0)
+ (beta #C(0.0d0 0.0d0)) (cdum #C(0.0d0 0.0d0)) (s #C(0.0d0 0.0d0))
+ (tau #C(0.0d0 0.0d0)) (dconjg$ 0.0))
+ (declare
+ (type (f2cl-lib:integer4) lwkopt lwk2 lwk1 ltop kwtop
+ krow knt kln kcol jw j
+ infqr info ilst ifst i)
+ (type (double-float) ulp smlnum safmin safmax foo)
+ (type (f2cl-lib:complex16) tau s cdum beta)
+ (type (single-float) dconjg$))
+ (setf jw
+ (min (the f2cl-lib:integer4 nw)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add (f2cl-lib:int-sub kbot ktop) 1))))
+ (cond ((<= jw 2) (setf lwkopt 1))
+ (t
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
+ (zgehrd jw 1 (f2cl-lib:int-sub jw 1) t$ ldt work work -1 info)
+ (declare (ignore var-1 var-2 var-3 var-5 var-6 var-7))
+ (setf jw var-0)
+ (setf ldt var-4) (setf info var-8))
+ (setf lwk1
+ (f2cl-lib:int
+ (f2cl-lib:fref work-%data% (1) ((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 var-10 var-11
+ var-12 var-13)
+ (zunmhr "R" "N" jw jw 1
+ (f2cl-lib:int-sub jw 1) t$ ldt work v ldv work -1
+ info)
+ (declare (ignore var-0 var-1 var-4 var-5 var-6 var-8 var-9
+ var-11 var-12))
+ (when var-2 (setf jw var-2)) (when var-3 (setf jw var-3))
+ (when var-7 (setf ldt var-7)) (when var-10 (setf ldv var-10))
+ (when var-13 (setf info var-13)))
+ (setf lwk2
+ (f2cl-lib:int (f2cl-lib:fref work-%data% (1) ((1 *))
+ work-%offset%)))
+ (setf lwkopt
+ (f2cl-lib:int-add jw
+ (max (the f2cl-lib:integer4 lwk1)
+ (the f2cl-lib:integer4 lwk2))))))
+ (cond
+ ((= lwork (f2cl-lib:int-sub 1))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (f2cl-lib:dcmplx lwkopt 0))
+ (go end_label)))
+ (setf ns 0) (setf nd 0)
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) one)
+ (if (> ktop kbot) (go end_label)) (if (< nw 1) (go end_label))
+ (setf safmin (dlamch "SAFE MINIMUM")) (setf safmax (/ rone safmin))
+ (multiple-value-bind (var-0 var-1) (dlabad safmin safmax)
+ (declare (ignore))
+ (when var-0 (setf safmin var-0)) (when var-1 (setf safmax var-1)))
+ (setf ulp (dlamch "PRECISION"))
+ (setf smlnum (* safmin (/ (f2cl-lib:dble n) ulp)))
+ (setf jw
+ (min (the f2cl-lib:integer4 nw)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add (f2cl-lib:int-sub kbot ktop) 1))))
+ (setf kwtop (f2cl-lib:int-add (f2cl-lib:int-sub kbot jw) 1))
+ (cond ((= kwtop ktop) (setf s zero))
+ (t
+ (setf s
+ (f2cl-lib:fref h-%data%
+ (kwtop (f2cl-lib:int-sub kwtop 1)) ((1 ldh) (1 *))
+ h-%offset%))))
+ (cond
+ ((= kbot kwtop)
+ (setf (f2cl-lib:fref sh-%data% (kwtop) ((1 *)) sh-%offset%)
+ (f2cl-lib:fref h-%data% (kwtop kwtop) ((1 ldh) (1 *)) h-%offset%))
+ (setf ns 1) (setf nd 0)
+ (cond
+ ((<= (cabs1 s)
+ (max smlnum
+ (* ulp (cabs1
+ (f2cl-lib:fref h (kwtop kwtop) ((1 ldh) (1 *)))))))
+ (setf ns 0) (setf nd 1)
+ (if (> kwtop ktop)
+ (setf
+ (f2cl-lib:fref h-%data% (kwtop (f2cl-lib:int-sub kwtop 1))
+ ((1 ldh) (1 *)) h-%offset%)
+ zero))))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) one)
+ (go end_label)))
+ (zlacpy "U" jw jw
+ (f2cl-lib:array-slice h-%data% f2cl-lib:complex16 (kwtop kwtop)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh t$ ldt)
+ (zcopy (f2cl-lib:int-sub jw 1)
+ (f2cl-lib:array-slice h-%data% f2cl-lib:complex16 ((+ kwtop 1) kwtop)
+ ((1 ldh) (1 *)) h-%offset%)
+ (f2cl-lib:int-add ldh 1)
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16 (2 1)
+ ((1 ldt) (1 *))
+ t$-%offset%)
+ (f2cl-lib:int-add ldt 1))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (zlaset "A" jw jw zero one v ldv) (declare (ignore var-0 var-5))
+ (when var-1 (setf jw var-1)) (when var-2 (setf jw var-2))
+ (when var-3 (setf zero var-3)) (when var-4 (setf one var-4))
+ (when var-6 (setf ldv var-6)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
+ var-9 var-10 var-11
+ var-12)
+ (zlahqr f2cl-lib:%true% f2cl-lib:%true% jw 1 jw t$ ldt
+ (f2cl-lib:array-slice sh-%data% f2cl-lib:complex16 (kwtop) ((1 *))
+ sh-%offset%)
+ 1 jw v ldv infqr)
+ (declare
+ (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-7 var-8 var-9 var-10
+ var-11))
+ (setf ldt var-6) (setf infqr var-12))
+ (setf ns jw) (setf ilst (f2cl-lib:int-add infqr 1))
+ (f2cl-lib:fdo (knt (f2cl-lib:int-add infqr 1)
+ (f2cl-lib:int-add knt 1))
+ ((>
+ knt jw)
+ nil)
+ (tagbody
+ (setf foo
+ (cabs1 (f2cl-lib:fref t$-%data% (ns ns)
+ ((1 ldt) (1 *)) t$-%offset%)))
+ (if (= foo rzero) (setf foo (cabs1 s)))
+ (cond
+ ((<= (* (cabs1 s)
+ (cabs1 (f2cl-lib:fref v (1 ns) ((1 ldv) (1 *)))))
+ (max smlnum (* ulp foo)))
+ (setf ns (f2cl-lib:int-sub ns 1)))
+ (t (setf ifst ns)
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
+ (ztrexc "V" jw t$ ldt v ldv ifst ilst info)
+ (declare (ignore var-0 var-2 var-4))
+ (when var-1 (setf jw var-1))
+ (when var-3 (setf ldt var-3))
+ (when var-5 (setf ldv var-5))
+ (when var-6 (setf ifst var-6))
+ (when var-7 (setf ilst var-7))
+ (when var-8 (setf info var-8)))
+ (setf ilst (f2cl-lib:int-add ilst 1))))
+ label10))
+ (if (= ns 0) (setf s zero))
+ (cond
+ ((< ns jw)
+ (f2cl-lib:fdo (i (f2cl-lib:int-add infqr 1) (f2cl-lib:int-add i 1))
+ ((> i
+ ns)
+ nil)
+ (tagbody (setf ifst i)
+ (f2cl-lib:fdo (j (f2cl-lib:int-add i 1)
+ (f2cl-lib:int-add j 1))
+ ((> j ns)
+ nil)
+ (tagbody
+ (if
+ (> (cabs1 (f2cl-lib:fref t$-%data% (j j)
+ ((1 ldt) (1 *)) t$-%offset%))
+ (cabs1
+ (f2cl-lib:fref t$-%data% (ifst ifst)
+ ((1 ldt) (1 *)) t$-%offset%)))
+ (setf ifst j))
+ label20))
+ (setf ilst i)
+ (if (/= ifst ilst)
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6
+ var-7 var-8)
+ (ztrexc "V" jw t$ ldt v ldv ifst ilst info)
+ (declare (ignore var-0 var-2 var-4))
+ (when var-1 (setf jw var-1))
+ (when var-3 (setf ldt var-3))
+ (when var-5 (setf ldv var-5))
+ (when var-6 (setf ifst var-6))
+ (when var-7 (setf ilst var-7))
+ (when var-8 (setf info var-8))))
+ label30))))
+ (f2cl-lib:fdo (i (f2cl-lib:int-add infqr 1) (f2cl-lib:int-add i 1))
+ ((> i jw)
+ nil)
+ (tagbody
+ (setf
+ (f2cl-lib:fref sh-%data%
+ ((f2cl-lib:int-sub (f2cl-lib:int-add kwtop i) 1))
+ ((1 *)) sh-%offset%)
+ (f2cl-lib:fref t$-%data% (i i) ((1 ldt) (1 *))
+ t$-%offset%))
+ label40))
+ (cond
+ ((or (< ns jw) (= s zero))
+ (cond
+ ((and (> ns 1) (/= s zero))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
+ (zcopy ns v ldv work 1) (declare (ignore var-1 var-3 var-4))
+ (when var-0 (setf ns var-0)) (when var-2 (setf ldv var-2)))
+ (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
+ ((> i ns) nil)
+ (tagbody
+ (setf (f2cl-lib:fref work-%data% (i) ((1 *))
+ work-%offset%)
+ (coerce
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref work-%data% (i) ((1 *))
+ work-%offset%))
+ 'f2cl-lib:complex16))
+ label50))
+ (setf beta (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
+ (zlarfg ns beta
+ (f2cl-lib:array-slice work-%data% f2cl-lib:complex16 (2) ((1 *))
+ work-%offset%)
+ 1 tau)
+ (declare (ignore var-2 var-3)) (when var-0 (setf ns var-0))
+ (when var-1 (setf beta var-1)) (when var-4 (setf tau var-4)))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) one)
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (zlaset "L"
+ (f2cl-lib:int-sub jw 2) (f2cl-lib:int-sub jw 2) zero zero
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16 (3 1)
+ ((1 ldt) (1 *)) t$-%offset%)
+ ldt)
+ (declare (ignore var-0 var-1 var-2 var-5))
+ (when var-3 (setf zero var-3)) (when var-4 (setf zero var-4))
+ (when var-6 (setf ldt var-6)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
+ (zlarf "L" ns jw work 1 (f2cl-lib:dconjg tau) t$ ldt
+ (f2cl-lib:array-slice work-%data% f2cl-lib:complex16
+ ((+ jw 1)) ((1 *))
+ work-%offset%))
+ (declare (ignore var-0 var-3 var-4 var-5 var-6 var-8))
+ (when var-1 (setf ns var-1)) (when var-2 (setf jw var-2))
+ (when var-7 (setf ldt var-7)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
+ (zlarf "R" ns ns work 1 tau t$ ldt
+ (f2cl-lib:array-slice work-%data% f2cl-lib:complex16
+ ((+ jw 1)) ((1 *))
+ work-%offset%))
+ (declare (ignore var-0 var-3 var-4 var-6 var-8))
+ (when var-1 (setf ns var-1)) (when var-2 (setf ns var-2))
+ (when var-5 (setf tau var-5)) (when var-7 (setf ldt var-7)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
+ (zlarf "R" jw ns work 1 tau v ldv
+ (f2cl-lib:array-slice work-%data% f2cl-lib:complex16
+ ((+ jw 1)) ((1 *))
+ work-%offset%))
+ (declare (ignore var-0 var-3 var-4 var-6 var-8))
+ (when var-1 (setf jw var-1)) (when var-2 (setf ns var-2))
+ (when var-5 (setf tau var-5)) (when var-7 (setf ldv var-7)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
+ (zgehrd jw 1 ns t$ ldt work
+ (f2cl-lib:array-slice work-%data% f2cl-lib:complex16
+ ((+ jw 1)) ((1 *))
+ work-%offset%)
+ (f2cl-lib:int-sub lwork jw) info)
+ (declare (ignore var-1 var-3 var-5 var-6 var-7)) (setf jw var-0)
+ (setf ns var-2) (setf ldt var-4) (setf info var-8))))
+ (if (> kwtop 1)
+ (setf
+ (f2cl-lib:fref h-%data% (kwtop (f2cl-lib:int-sub kwtop 1))
+ ((1 ldh) (1 *)) h-%offset%)
+ (coerce
+ (* s
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref v-%data% (1 1) ((1 ldv) (1 *)) v-%offset%)))
+ 'f2cl-lib:complex16)))
+ (zlacpy "U" jw jw t$ ldt
+ (f2cl-lib:array-slice h-%data% f2cl-lib:complex16 (kwtop kwtop)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh)
+ (zcopy (f2cl-lib:int-sub jw 1)
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16
+ (2 1) ((1 ldt) (1 *))
+ t$-%offset%)
+ (f2cl-lib:int-add ldt 1)
+ (f2cl-lib:array-slice h-%data% f2cl-lib:complex16
+ ((+ kwtop 1) kwtop)
+ ((1 ldh) (1 *)) h-%offset%)
+ (f2cl-lib:int-add ldh 1))
+ (if (and (> ns 1) (/= s zero))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
+ var-9 var-10
+ var-11 var-12 var-13)
+ (zunmhr "R" "N" jw ns 1 ns t$ ldt work v ldv
+ (f2cl-lib:array-slice work-%data% f2cl-lib:complex16
+ ((+ jw 1)) ((1 *))
+ work-%offset%)
+ (f2cl-lib:int-sub lwork jw) info)
+ (declare (ignore var-0 var-1 var-4 var-6 var-8 var-9 var-11
+ var-12))
+ (when var-2 (setf jw var-2)) (when var-3 (setf ns var-3))
+ (when var-5 (setf ns var-5)) (when var-7 (setf ldt var-7))
+ (when var-10 (setf ldv var-10)) (when var-13 (setf info var-13))))
+ (cond (wantt (setf ltop 1)) (t (setf ltop ktop)))
+ (f2cl-lib:fdo (krow ltop (f2cl-lib:int-add krow nv))
+ ((> krow
+ (f2cl-lib:int-add kwtop (f2cl-lib:int-sub 1)))
+ nil)
+ (tagbody
+ (setf kln
+ (min (the f2cl-lib:integer4 nv)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-sub kwtop krow))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6
+ var-7 var-8 var-9 var-10
+ var-11 var-12)
+ (zgemm "N" "N" kln jw jw one
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (krow kwtop)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh v ldv zero wv ldwv)
+ (declare (ignore var-0 var-1 var-6 var-8 var-11))
+ (when var-2 (setf kln var-2))
+ (when var-3 (setf jw var-3))
+ (when var-4 (setf jw var-4))
+ (when var-5 (setf one var-5))
+ (when var-7 (setf ldh var-7))
+ (when var-9 (setf ldv var-9))
+ (when var-10 (setf zero var-10))
+ (when var-12 (setf ldwv var-12)))
+ (zlacpy "A" kln jw wv ldwv
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (krow kwtop)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh)
+ label60))
+ (cond
+ (wantt
+ (f2cl-lib:fdo (kcol (f2cl-lib:int-add kbot 1)
+ (f2cl-lib:int-add kcol nh))
+ ((> kcol n) nil)
+ (tagbody
+ (setf kln
+ (min (the f2cl-lib:integer4 nh)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add
+ (f2cl-lib:int-sub n kcol) 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)
+ (zgemm "C" "N" jw kln jw one v ldv
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (kwtop kcol)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh zero t$ ldt)
+ (declare (ignore var-0 var-1 var-6 var-8 var-11))
+ (when var-2 (setf jw var-2))
+ (when var-3 (setf kln var-3))
+ (when var-4 (setf jw var-4))
+ (when var-5 (setf one var-5))
+ (when var-7 (setf ldv var-7))
+ (when var-9 (setf ldh var-9))
+ (when var-10 (setf zero var-10))
+ (when var-12 (setf ldt var-12)))
+ (zlacpy "A" jw kln t$ ldt
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (kwtop kcol)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh)
+ label70))))
+ (cond
+ (wantz
+ (f2cl-lib:fdo (krow iloz (f2cl-lib:int-add krow nv))
+ ((> krow ihiz)
+ nil)
+ (tagbody
+ (setf kln
+ (min (the f2cl-lib:integer4 nv)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add
+ (f2cl-lib:int-sub ihiz krow) 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)
+ (zgemm "N" "N" kln jw jw one
+ (f2cl-lib:array-slice z-%data%
+ f2cl-lib:complex16 (krow kwtop)
+ ((1 ldz) (1 *)) z-%offset%)
+ ldz v ldv zero wv ldwv)
+ (declare (ignore var-0 var-1 var-6 var-8 var-11))
+ (when var-2 (setf kln var-2))
+ (when var-3 (setf jw var-3))
+ (when var-4 (setf jw var-4))
+ (when var-5 (setf one var-5))
+ (when var-7 (setf ldz var-7))
+ (when var-9 (setf ldv var-9))
+ (when var-10 (setf zero var-10))
+ (when var-12 (setf ldwv var-12)))
+ (zlacpy "A" kln jw wv ldwv
+ (f2cl-lib:array-slice z-%data%
+ f2cl-lib:complex16 (krow kwtop)
+ ((1 ldz) (1 *)) z-%offset%)
+ ldz)
+ label80))))))
+ (setf nd (f2cl-lib:int-sub jw ns))
+ (setf ns (f2cl-lib:int-sub ns infqr))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (f2cl-lib:dcmplx lwkopt 0))
+ end_label
+ (return
+ (values nil nil nil nil nil nil nil ldh nil nil nil ldz ns nd nil
+ nil ldv nil nil ldt nil nil ldwv nil nil)))))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -112888,7 +119978,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlaqr3.f}
* =====================================================================
SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
$ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
@@ -113204,10 +120294,498 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlaqr3}
-
+(let*
+ ((zero (coerce (f2cl-lib:cmplx 0.0d0 0.0d0) 'f2cl-lib:complex16))
+ (one (coerce (f2cl-lib:cmplx 1.0d0 0.0d0) 'f2cl-lib:complex16)) (rzero 0.0d0)
+ (rone 1.0d0))
+ (declare (type (f2cl-lib:complex16) zero) (type (f2cl-lib:complex16) one)
+ (type (double-float 0.0d0 0.0d0) rzero)
+ (type (double-float 1.0d0 1.0d0) rone) (ignorable zero one rzero rone))
+ (defun zlaqr3
+ (wantt wantz n ktop kbot nw h ldh iloz ihiz z ldz ns nd sh v ldv nh t$ ldt nv
+ wv ldwv work lwork)
+ (declare (type f2cl-lib:logical wantz wantt)
+ (type (f2cl-lib:integer4) lwork ldwv nv ldt nh ldv nd ns ldz ihiz iloz ldh
+ nw kbot ktop n)
+ (type (array f2cl-lib:complex16 (*)) work wv t$ v sh z h))
+ (f2cl-lib:with-multi-array-data
+ ((h f2cl-lib:complex16 h-%data% h-%offset%)
+ (z f2cl-lib:complex16 z-%data% z-%offset%)
+ (sh f2cl-lib:complex16 sh-%data% sh-%offset%)
+ (v f2cl-lib:complex16 v-%data% v-%offset%)
+ (t$ f2cl-lib:complex16 t$-%data% t$-%offset%)
+ (wv f2cl-lib:complex16 wv-%data% wv-%offset%)
+ (work f2cl-lib:complex16 work-%data% work-%offset%))
+ (labels
+ ((cabs1 (cdum)
+ (+ (abs (f2cl-lib:dble cdum)) (abs (f2cl-lib:dimag cdum)))))
+ (declare
+ (ftype (function (f2cl-lib:complex16)
+ (values double-float &rest t)) cabs1))
+ (prog
+ ((i 0) (ifst 0) (ilst 0) (info 0) (infqr 0) (j 0) (jw 0)
+ (kcol 0) (kln 0)
+ (knt 0) (krow 0) (kwtop 0) (ltop 0) (lwk1 0) (lwk2 0)
+ (lwk3 0) (lwkopt 0)
+ (nmin 0) (foo 0.0d0) (safmax 0.0d0) (safmin 0.0d0) (smlnum 0.0d0)
+ (ulp 0.0d0) (beta #C(0.0d0 0.0d0)) (cdum #C(0.0d0 0.0d0))
+ (s #C(0.0d0 0.0d0)) (tau #C(0.0d0 0.0d0)) (dconjg$ 0.0))
+ (declare
+ (type (f2cl-lib:integer4) nmin lwkopt lwk3 lwk2 lwk1 ltop
+ kwtop krow knt kln
+ kcol jw j infqr info ilst ifst i)
+ (type (double-float) ulp smlnum safmin safmax foo)
+ (type (f2cl-lib:complex16) tau s cdum beta)
+ (type (single-float) dconjg$))
+ (setf jw
+ (min (the f2cl-lib:integer4 nw)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add (f2cl-lib:int-sub kbot ktop) 1))))
+ (cond ((<= jw 2) (setf lwkopt 1))
+ (t
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
+ (zgehrd jw 1 (f2cl-lib:int-sub jw 1) t$ ldt work work -1 info)
+ (declare (ignore var-1 var-2 var-3 var-5 var-6 var-7))
+ (setf jw var-0)
+ (setf ldt var-4) (setf info var-8))
+ (setf lwk1
+ (f2cl-lib:int
+ (f2cl-lib:fref work-%data% (1) ((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 var-10 var-11
+ var-12 var-13)
+ (zunmhr "R" "N" jw jw 1
+ (f2cl-lib:int-sub jw 1) t$ ldt work v ldv work -1
+ info)
+ (declare (ignore var-0 var-1 var-4 var-5 var-6 var-8
+ var-9 var-11 var-12))
+ (when var-2 (setf jw var-2)) (when var-3 (setf jw var-3))
+ (when var-7 (setf ldt var-7)) (when var-10 (setf ldv var-10))
+ (when var-13 (setf info var-13)))
+ (setf lwk2
+ (f2cl-lib:int
+ (f2cl-lib:fref work-%data% (1) ((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 var-10 var-11
+ var-12 var-13 var-14)
+ (zlaqr4 f2cl-lib:%true% f2cl-lib:%true%
+ jw 1 jw t$ ldt sh 1 jw v ldv work
+ -1 infqr)
+ (declare
+ (ignore var-0 var-1 var-3 var-5 var-7 var-8 var-10 var-12 var-13))
+ (when var-2 (setf jw var-2)) (when var-4 (setf jw var-4))
+ (when var-6 (setf ldt var-6)) (when var-9 (setf jw var-9))
+ (when var-11 (setf ldv var-11)) (when var-14 (setf infqr var-14)))
+ (setf lwk3
+ (f2cl-lib:int (f2cl-lib:fref work-%data% (1) ((1 *))
+ work-%offset%)))
+ (setf lwkopt
+ (max
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add jw
+ (max (the f2cl-lib:integer4 lwk1)
+ (the f2cl-lib:integer4 lwk2))))
+ (the f2cl-lib:integer4 lwk3)))))
+ (cond
+ ((= lwork (f2cl-lib:int-sub 1))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (f2cl-lib:dcmplx lwkopt 0))
+ (go end_label)))
+ (setf ns 0) (setf nd 0)
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) one)
+ (if (> ktop kbot) (go end_label)) (if (< nw 1) (go end_label))
+ (setf safmin (dlamch "SAFE MINIMUM")) (setf safmax (/ rone safmin))
+ (multiple-value-bind (var-0 var-1)
+ (dlabad safmin safmax) (declare (ignore))
+ (when var-0 (setf safmin var-0)) (when var-1 (setf safmax var-1)))
+ (setf ulp (dlamch "PRECISION"))
+ (setf smlnum (* safmin (/ (f2cl-lib:dble n) ulp)))
+ (setf jw
+ (min (the f2cl-lib:integer4 nw)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add (f2cl-lib:int-sub kbot ktop) 1))))
+ (setf kwtop (f2cl-lib:int-add (f2cl-lib:int-sub kbot jw) 1))
+ (cond ((= kwtop ktop) (setf s zero))
+ (t
+ (setf s
+ (f2cl-lib:fref h-%data%
+ (kwtop (f2cl-lib:int-sub kwtop 1)) ((1 ldh) (1 *))
+ h-%offset%))))
+ (cond
+ ((= kbot kwtop)
+ (setf (f2cl-lib:fref sh-%data% (kwtop) ((1 *)) sh-%offset%)
+ (f2cl-lib:fref h-%data% (kwtop kwtop) ((1 ldh) (1 *)) h-%offset%))
+ (setf ns 1) (setf nd 0)
+ (cond
+ ((<= (cabs1 s)
+ (max smlnum
+ (* ulp (cabs1
+ (f2cl-lib:fref h (kwtop kwtop) ((1 ldh) (1 *)))))))
+ (setf ns 0) (setf nd 1)
+ (if (> kwtop ktop)
+ (setf
+ (f2cl-lib:fref h-%data% (kwtop (f2cl-lib:int-sub kwtop 1))
+ ((1 ldh) (1 *)) h-%offset%)
+ zero))))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) one)
+ (go end_label)))
+ (zlacpy "U" jw jw
+ (f2cl-lib:array-slice h-%data% f2cl-lib:complex16 (kwtop kwtop)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh t$ ldt)
+ (zcopy (f2cl-lib:int-sub jw 1)
+ (f2cl-lib:array-slice h-%data% f2cl-lib:complex16 ((+ kwtop 1) kwtop)
+ ((1 ldh) (1 *)) h-%offset%)
+ (f2cl-lib:int-add ldh 1)
+ (f2cl-lib:array-slice t$-%data%
+ f2cl-lib:complex16 (2 1) ((1 ldt) (1 *))
+ t$-%offset%)
+ (f2cl-lib:int-add ldt 1))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (zlaset "A" jw jw zero one v ldv) (declare (ignore var-0 var-5))
+ (when var-1 (setf jw var-1)) (when var-2 (setf jw var-2))
+ (when var-3 (setf zero var-3)) (when var-4 (setf one var-4))
+ (when var-6 (setf ldv var-6)))
+ (setf nmin
+ (multiple-value-bind (ret-val var-0 var-1 var-2 var-3
+ var-4 var-5 var-6)
+ (ilaenv 12 "ZLAQR3" "SV" jw 1 jw lwork)
+ (declare (ignore var-0 var-1 var-2 var-4))
+ (when var-3 (setf jw var-3))
+ (when var-5 (setf jw var-5))
+ (when var-6 (setf lwork var-6)) ret-val))
+ (cond
+ ((> jw nmin)
+ (multiple-value-bind
+ (var-0 var-1 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)
+ (zlaqr4 f2cl-lib:%true% f2cl-lib:%true% jw 1 jw t$ ldt
+ (f2cl-lib:array-slice sh-%data% f2cl-lib:complex16 (kwtop) ((1 *))
+ sh-%offset%)
+ 1 jw v ldv work lwork infqr)
+ (declare (ignore var-0 var-1 var-3 var-5 var-7 var-8
+ var-10 var-12))
+ (when var-2 (setf jw var-2)) (when var-4 (setf jw var-4))
+ (when var-6 (setf ldt var-6)) (when var-9 (setf jw var-9))
+ (when var-11 (setf ldv var-11)) (when var-13 (setf lwork var-13))
+ (when var-14 (setf infqr 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)
+ (zlahqr f2cl-lib:%true% f2cl-lib:%true% jw 1 jw t$ ldt
+ (f2cl-lib:array-slice sh-%data% f2cl-lib:complex16 (kwtop) ((1 *))
+ sh-%offset%)
+ 1 jw v ldv infqr)
+ (declare
+ (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-7 var-8
+ var-9 var-10
+ var-11))
+ (setf ldt var-6) (setf infqr var-12))))
+ (setf ns jw) (setf ilst (f2cl-lib:int-add infqr 1))
+ (f2cl-lib:fdo (knt (f2cl-lib:int-add infqr 1)
+ (f2cl-lib:int-add knt 1))
+ ((>
+ knt jw)
+ nil)
+ (tagbody
+ (setf foo
+ (cabs1 (f2cl-lib:fref t$-%data% (ns ns)
+ ((1 ldt) (1 *)) t$-%offset%)))
+ (if (= foo rzero) (setf foo (cabs1 s)))
+ (cond
+ ((<= (* (cabs1 s)
+ (cabs1 (f2cl-lib:fref v (1 ns) ((1 ldv) (1 *)))))
+ (max smlnum (* ulp foo)))
+ (setf ns (f2cl-lib:int-sub ns 1)))
+ (t (setf ifst ns)
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
+ (ztrexc "V" jw t$ ldt v ldv ifst ilst info)
+ (declare (ignore var-0 var-2 var-4))
+ (when var-1 (setf jw var-1))
+ (when var-3 (setf ldt var-3))
+ (when var-5 (setf ldv var-5))
+ (when var-6 (setf ifst var-6))
+ (when var-7 (setf ilst var-7))
+ (when var-8 (setf info var-8)))
+ (setf ilst (f2cl-lib:int-add ilst 1))))
+ label10))
+ (if (= ns 0) (setf s zero))
+ (cond
+ ((< ns jw)
+ (f2cl-lib:fdo (i (f2cl-lib:int-add infqr 1) (f2cl-lib:int-add i 1))
+ ((> i
+ ns)
+ nil)
+ (tagbody (setf ifst i)
+ (f2cl-lib:fdo
+ (j (f2cl-lib:int-add i 1) (f2cl-lib:int-add j 1))
+ ((> j ns)
+ nil)
+ (tagbody
+ (if
+ (> (cabs1 (f2cl-lib:fref t$-%data% (j j)
+ ((1 ldt) (1 *)) t$-%offset%))
+ (cabs1
+ (f2cl-lib:fref t$-%data% (ifst ifst)
+ ((1 ldt) (1 *)) t$-%offset%)))
+ (setf ifst j))
+ label20))
+ (setf ilst i)
+ (if (/= ifst ilst)
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6
+ var-7 var-8)
+ (ztrexc "V" jw t$ ldt v ldv ifst ilst info)
+ (declare (ignore var-0 var-2 var-4))
+ (when var-1 (setf jw var-1))
+ (when var-3 (setf ldt var-3))
+ (when var-5 (setf ldv var-5))
+ (when var-6 (setf ifst var-6))
+ (when var-7 (setf ilst var-7))
+ (when var-8 (setf info var-8))))
+ label30))))
+ (f2cl-lib:fdo (i (f2cl-lib:int-add infqr 1) (f2cl-lib:int-add i 1))
+ ((> i jw)
+ nil)
+ (tagbody
+ (setf
+ (f2cl-lib:fref sh-%data%
+ ((f2cl-lib:int-sub (f2cl-lib:int-add kwtop i) 1))
+ ((1 *)) sh-%offset%)
+ (f2cl-lib:fref t$-%data% (i i) ((1 ldt) (1 *))
+ t$-%offset%))
+ label40))
+ (cond
+ ((or (< ns jw) (= s zero))
+ (cond
+ ((and (> ns 1) (/= s zero))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
+ (zcopy ns v ldv work 1) (declare (ignore var-1 var-3 var-4))
+ (when var-0 (setf ns var-0)) (when var-2 (setf ldv var-2)))
+ (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
+ ((> i ns) nil)
+ (tagbody
+ (setf (f2cl-lib:fref work-%data% (i) ((1 *))
+ work-%offset%)
+ (coerce
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref work-%data% (i) ((1 *))
+ work-%offset%))
+ 'f2cl-lib:complex16))
+ label50))
+ (setf beta (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
+ (zlarfg ns beta
+ (f2cl-lib:array-slice work-%data% f2cl-lib:complex16 (2) ((1 *))
+ work-%offset%)
+ 1 tau)
+ (declare (ignore var-2 var-3)) (when var-0 (setf ns var-0))
+ (when var-1 (setf beta var-1)) (when var-4 (setf tau var-4)))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) one)
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (zlaset "L"
+ (f2cl-lib:int-sub jw 2) (f2cl-lib:int-sub jw 2) zero zero
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16 (3 1)
+ ((1 ldt) (1 *)) t$-%offset%)
+ ldt)
+ (declare (ignore var-0 var-1 var-2 var-5))
+ (when var-3 (setf zero var-3)) (when var-4 (setf zero var-4))
+ (when var-6 (setf ldt var-6)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
+ (zlarf "L" ns jw work 1 (f2cl-lib:dconjg tau) t$ ldt
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 ((+ jw 1)) ((1 *))
+ work-%offset%))
+ (declare (ignore var-0 var-3 var-4 var-5 var-6 var-8))
+ (when var-1 (setf ns var-1)) (when var-2 (setf jw var-2))
+ (when var-7 (setf ldt var-7)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
+ (zlarf "R" ns ns work 1 tau t$ ldt
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 ((+ jw 1)) ((1 *))
+ work-%offset%))
+ (declare (ignore var-0 var-3 var-4 var-6 var-8))
+ (when var-1 (setf ns var-1)) (when var-2 (setf ns var-2))
+ (when var-5 (setf tau var-5)) (when var-7 (setf ldt var-7)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
+ (zlarf "R" jw ns work 1 tau v ldv
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 ((+ jw 1)) ((1 *))
+ work-%offset%))
+ (declare (ignore var-0 var-3 var-4 var-6 var-8))
+ (when var-1 (setf jw var-1)) (when var-2 (setf ns var-2))
+ (when var-5 (setf tau var-5)) (when var-7 (setf ldv var-7)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
+ (zgehrd jw 1 ns t$ ldt work
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 ((+ jw 1)) ((1 *))
+ work-%offset%)
+ (f2cl-lib:int-sub lwork jw) info)
+ (declare (ignore var-1 var-3 var-5 var-6 var-7)) (setf jw var-0)
+ (setf ns var-2) (setf ldt var-4) (setf info var-8))))
+ (if (> kwtop 1)
+ (setf
+ (f2cl-lib:fref h-%data% (kwtop (f2cl-lib:int-sub kwtop 1))
+ ((1 ldh) (1 *)) h-%offset%)
+ (coerce
+ (* s
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref v-%data% (1 1) ((1 ldv) (1 *)) v-%offset%)))
+ 'f2cl-lib:complex16)))
+ (zlacpy "U" jw jw t$ ldt
+ (f2cl-lib:array-slice h-%data% f2cl-lib:complex16 (kwtop kwtop)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh)
+ (zcopy (f2cl-lib:int-sub jw 1)
+ (f2cl-lib:array-slice t$-%data%
+ f2cl-lib:complex16 (2 1) ((1 ldt) (1 *))
+ t$-%offset%)
+ (f2cl-lib:int-add ldt 1)
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 ((+ kwtop 1) kwtop)
+ ((1 ldh) (1 *)) h-%offset%)
+ (f2cl-lib:int-add ldh 1))
+ (if (and (> ns 1) (/= s zero))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
+ var-9 var-10
+ var-11 var-12 var-13)
+ (zunmhr "R" "N" jw ns 1 ns t$ ldt work v ldv
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 ((+ jw 1)) ((1 *))
+ work-%offset%)
+ (f2cl-lib:int-sub lwork jw) info)
+ (declare
+ (ignore var-0 var-1 var-4 var-6 var-8 var-9 var-11 var-12))
+ (when var-2 (setf jw var-2)) (when var-3 (setf ns var-3))
+ (when var-5 (setf ns var-5)) (when var-7 (setf ldt var-7))
+ (when var-10 (setf ldv var-10)) (when var-13 (setf info var-13))))
+ (cond (wantt (setf ltop 1)) (t (setf ltop ktop)))
+ (f2cl-lib:fdo (krow ltop (f2cl-lib:int-add krow nv))
+ ((> krow
+ (f2cl-lib:int-add kwtop (f2cl-lib:int-sub 1)))
+ nil)
+ (tagbody
+ (setf kln
+ (min (the f2cl-lib:integer4 nv)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-sub kwtop krow))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6
+ var-7 var-8 var-9 var-10
+ var-11 var-12)
+ (zgemm "N" "N" kln jw jw one
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (krow kwtop)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh v ldv zero wv ldwv)
+ (declare (ignore var-0 var-1 var-6 var-8 var-11))
+ (when var-2 (setf kln var-2))
+ (when var-3 (setf jw var-3))
+ (when var-4 (setf jw var-4))
+ (when var-5 (setf one var-5))
+ (when var-7 (setf ldh var-7))
+ (when var-9 (setf ldv var-9))
+ (when var-10 (setf zero var-10))
+ (when var-12 (setf ldwv var-12)))
+ (zlacpy "A" kln jw wv ldwv
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (krow kwtop)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh)
+ label60))
+ (cond
+ (wantt
+ (f2cl-lib:fdo (kcol (f2cl-lib:int-add kbot 1)
+ (f2cl-lib:int-add kcol nh))
+ ((> kcol n) nil)
+ (tagbody
+ (setf kln
+ (min (the f2cl-lib:integer4 nh)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add
+ (f2cl-lib:int-sub n kcol) 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)
+ (zgemm "C" "N" jw kln jw one v ldv
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (kwtop kcol)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh zero t$ ldt)
+ (declare (ignore var-0 var-1 var-6 var-8 var-11))
+ (when var-2 (setf jw var-2))
+ (when var-3 (setf kln var-3))
+ (when var-4 (setf jw var-4))
+ (when var-5 (setf one var-5))
+ (when var-7 (setf ldv var-7))
+ (when var-9 (setf ldh var-9))
+ (when var-10 (setf zero var-10))
+ (when var-12 (setf ldt var-12)))
+ (zlacpy "A" jw kln t$ ldt
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (kwtop kcol)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh)
+ label70))))
+ (cond
+ (wantz
+ (f2cl-lib:fdo (krow iloz (f2cl-lib:int-add krow nv))
+ ((> krow ihiz)
+ nil)
+ (tagbody
+ (setf kln
+ (min (the f2cl-lib:integer4 nv)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add
+ (f2cl-lib:int-sub ihiz krow) 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)
+ (zgemm "N" "N" kln jw jw one
+ (f2cl-lib:array-slice z-%data%
+ f2cl-lib:complex16 (krow kwtop)
+ ((1 ldz) (1 *)) z-%offset%)
+ ldz v ldv zero wv ldwv)
+ (declare (ignore var-0 var-1 var-6 var-8 var-11))
+ (when var-2 (setf kln var-2))
+ (when var-3 (setf jw var-3))
+ (when var-4 (setf jw var-4))
+ (when var-5 (setf one var-5))
+ (when var-7 (setf ldz var-7))
+ (when var-9 (setf ldv var-9))
+ (when var-10 (setf zero var-10))
+ (when var-12 (setf ldwv var-12)))
+ (zlacpy "A" kln jw wv ldwv
+ (f2cl-lib:array-slice z-%data%
+ f2cl-lib:complex16 (krow kwtop)
+ ((1 ldz) (1 *)) z-%offset%)
+ ldz)
+ label80))))))
+ (setf nd (f2cl-lib:int-sub jw ns))
+ (setf ns (f2cl-lib:int-sub ns infqr))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (f2cl-lib:dcmplx lwkopt 0))
+ end_label
+ (return
+ (values nil nil nil nil nil nil nil ldh nil nil nil ldz ns nd nil nil ldv
+ nil nil ldt nil nil ldwv nil lwork)))))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -113448,7 +121026,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlaqr4.f}
* =====================================================================
SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
$ IHIZ, Z, LDZ, WORK, LWORK, INFO )
@@ -113908,10 +121486,571 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlaqr4}
-
+(let*
+ ((ntiny 11) (kexnw 5) (kexsh 6) (wilk1 0.75d0)
+ (zero (coerce (f2cl-lib:cmplx 0.0d0 0.0d0) 'f2cl-lib:complex16))
+ (one (coerce (f2cl-lib:cmplx 1.0d0 0.0d0) 'f2cl-lib:complex16)) (two 2.0d0))
+ (declare (type (f2cl-lib:integer4 11 11) ntiny)
+ (type (f2cl-lib:integer4 5 5) kexnw) (type (f2cl-lib:integer4 6 6) kexsh)
+ (type (double-float 0.75d0 0.75d0) wilk1) (type (f2cl-lib:complex16) zero)
+ (type (f2cl-lib:complex16) one) (type (double-float 2.0d0 2.0d0) two)
+ (ignorable ntiny kexnw kexsh wilk1 zero one two))
+ (defun zlaqr4 (wantt wantz n ilo ihi h ldh w iloz ihiz z ldz work lwork info)
+ (declare (type f2cl-lib:logical wantz wantt)
+ (type (f2cl-lib:integer4) info lwork ldz ihiz iloz ldh ihi ilo n)
+ (type (array f2cl-lib:complex16 (*)) work z w h))
+ (f2cl-lib:with-multi-array-data
+ ((h f2cl-lib:complex16 h-%data% h-%offset%)
+ (w f2cl-lib:complex16 w-%data% w-%offset%)
+ (z f2cl-lib:complex16 z-%data% z-%offset%)
+ (work f2cl-lib:complex16 work-%data% work-%offset%))
+ (labels
+ ((cabs1 (cdum)
+ (+ (abs (f2cl-lib:dble cdum)) (abs (f2cl-lib:dimag cdum)))))
+ (declare
+ (ftype (function (f2cl-lib:complex16)
+ (values double-float &rest t)) cabs1))
+ (prog
+ ((zdum (make-array 1 :element-type 'f2cl-lib:complex16))
+ (jbcmpz (make-array '(2) :element-type 'character
+ :initial-element #\space))
+ (sorted nil) (i 0) (inf 0) (it 0) (itmax 0) (k 0) (kacc22 0) (kbot 0)
+ (kdu 0) (ks 0) (kt 0) (ktop 0) (ku 0) (kv 0) (kwh 0) (kwtop 0) (kwv 0)
+ (ld 0) (ls 0) (lwkopt 0) (ndec 0) (ndfl 0) (nh 0) (nho 0) (nibble 0)
+ (nmin 0) (ns 0) (nsmax 0) (nsr 0) (nve 0) (nw 0) (nwmax 0) (nwr 0)
+ (nwupbd 0) (s 0.0d0) (aa #C(0.0d0 0.0d0)) (bb #C(0.0d0 0.0d0))
+ (cc #C(0.0d0 0.0d0)) (cdum #C(0.0d0 0.0d0)) (dd #C(0.0d0 0.0d0))
+ (det #C(0.0d0 0.0d0)) (rtdisc #C(0.0d0 0.0d0)) (swap #C(0.0d0 0.0d0))
+ (tr2 #C(0.0d0 0.0d0)))
+ (declare (type (array f2cl-lib:complex16 (1)) zdum)
+ (type (simple-array character (2)) jbcmpz)
+ (type f2cl-lib:logical sorted)
+ (type (f2cl-lib:integer4) nwupbd nwr nwmax nw nve nsr nsmax
+ ns nmin nibble
+ nho nh ndfl ndec lwkopt ls ld kwv kwtop kwh kv ku ktop kt
+ ks kdu kbot
+ kacc22 k itmax it inf i)
+ (type (double-float) s)
+ (type (f2cl-lib:complex16) tr2 swap rtdisc det dd cdum cc bb aa))
+ (setf info 0)
+ (cond
+ ((= n 0)
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%) one)
+ (go end_label)))
+ (cond
+ ((<= n ntiny) (setf lwkopt 1)
+ (if (/= lwork -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)
+ (zlahqr wantt wantz n ilo ihi h ldh w iloz ihiz z ldz info)
+ (declare
+ (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-7
+ var-8 var-9 var-10
+ var-11))
+ (setf ldh var-6) (setf info var-12))))
+ (t
+ (tagbody (setf info 0)
+ (cond
+ (wantt
+ (f2cl-lib:fset-string (f2cl-lib:fref-string jbcmpz (1 1)) "S"))
+ (t
+ (f2cl-lib:fset-string (f2cl-lib:fref-string jbcmpz (1 1)) "E")))
+ (cond
+ (wantz
+ (f2cl-lib:fset-string (f2cl-lib:fref-string jbcmpz (2 2)) "V"))
+ (t
+ (f2cl-lib:fset-string (f2cl-lib:fref-string jbcmpz (2 2)) "N")))
+ (setf nwr
+ (multiple-value-bind
+ (ret-val var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (ilaenv 13 "ZLAQR4" jbcmpz n ilo ihi lwork)
+ (declare (ignore var-0 var-1)) (when var-2 (setf jbcmpz var-2))
+ (when var-3 (setf n var-3)) (when var-4 (setf ilo var-4))
+ (when var-5 (setf ihi var-5))
+ (when var-6 (setf lwork var-6)) ret-val))
+ (setf nwr (max (the f2cl-lib:integer4 2)
+ (the f2cl-lib:integer4 nwr)))
+ (setf nwr
+ (min (f2cl-lib:int-add (f2cl-lib:int-sub ihi ilo) 1)
+ (the f2cl-lib:integer4 (truncate (- n 1) 3)) nwr))
+ (setf nsr
+ (multiple-value-bind
+ (ret-val var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (ilaenv 15 "ZLAQR4" jbcmpz n ilo ihi lwork)
+ (declare (ignore var-0 var-1)) (when var-2 (setf jbcmpz var-2))
+ (when var-3 (setf n var-3)) (when var-4 (setf ilo var-4))
+ (when var-5 (setf ihi var-5))
+ (when var-6 (setf lwork var-6)) ret-val))
+ (setf nsr
+ (min nsr (the f2cl-lib:integer4 (truncate (+ n 6) 9))
+ (f2cl-lib:int-sub ihi ilo)))
+ (setf nsr
+ (max (the f2cl-lib:integer4 2)
+ (the f2cl-lib:integer4 (f2cl-lib:int-sub nsr (mod nsr 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 var-13 var-14 var-15 var-16 var-17
+ var-18 var-19 var-20
+ var-21 var-22 var-23 var-24)
+ (zlaqr2 wantt wantz n ilo ihi
+ (f2cl-lib:int-add nwr 1) h ldh iloz ihiz z
+ ldz ls ld w h ldh n h ldh n h ldh work -1)
+ (declare
+ (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8
+ var-9 var-10
+ var-14 var-15 var-17 var-18 var-20 var-21 var-23 var-24))
+ (setf ldh var-7)
+ (setf ldz var-11)
+ (setf ls var-12)
+ (setf ld var-13)
+ (setf ldh var-16)
+ (setf ldh var-19)
+ (setf ldh var-22))
+ (setf lwkopt
+ (max (the f2cl-lib:integer4 (truncate (* 3 nsr) 2))
+ (f2cl-lib:int
+ (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%))))
+ (cond
+ ((= lwork (f2cl-lib:int-sub 1))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (f2cl-lib:dcmplx lwkopt 0))
+ (go end_label)))
+ (setf nmin
+ (multiple-value-bind
+ (ret-val var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (ilaenv 12 "ZLAQR4" jbcmpz n ilo ihi lwork)
+ (declare (ignore var-0 var-1)) (when var-2 (setf jbcmpz var-2))
+ (when var-3 (setf n var-3)) (when var-4 (setf ilo var-4))
+ (when var-5 (setf ihi var-5))
+ (when var-6 (setf lwork var-6)) ret-val))
+ (setf nmin
+ (max (the f2cl-lib:integer4 ntiny) (the f2cl-lib:integer4 nmin)))
+ (setf nibble
+ (multiple-value-bind
+ (ret-val var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (ilaenv 14 "ZLAQR4" jbcmpz n ilo ihi lwork)
+ (declare (ignore var-0 var-1)) (when var-2 (setf jbcmpz var-2))
+ (when var-3 (setf n var-3)) (when var-4 (setf ilo var-4))
+ (when var-5 (setf ihi var-5))
+ (when var-6 (setf lwork var-6)) ret-val))
+ (setf nibble
+ (max (the f2cl-lib:integer4 0) (the f2cl-lib:integer4 nibble)))
+ (setf kacc22
+ (multiple-value-bind
+ (ret-val var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (ilaenv 16 "ZLAQR4" jbcmpz n ilo ihi lwork)
+ (declare (ignore var-0 var-1)) (when var-2 (setf jbcmpz var-2))
+ (when var-3 (setf n var-3)) (when var-4 (setf ilo var-4))
+ (when var-5 (setf ihi var-5))
+ (when var-6 (setf lwork var-6)) ret-val))
+ (setf kacc22
+ (max (the f2cl-lib:integer4 0) (the f2cl-lib:integer4 kacc22)))
+ (setf kacc22
+ (min (the f2cl-lib:integer4 2) (the f2cl-lib:integer4 kacc22)))
+ (setf nwmax
+ (min (the f2cl-lib:integer4 (truncate (- n 1) 3))
+ (the f2cl-lib:integer4 (truncate lwork 2))))
+ (setf nw nwmax)
+ (setf nsmax
+ (min (the f2cl-lib:integer4 (truncate (+ n 6) 9))
+ (the f2cl-lib:integer4 (truncate (* 2 lwork) 3))))
+ (setf nsmax (f2cl-lib:int-sub nsmax (mod nsmax 2))) (setf ndfl 1)
+ (setf itmax
+ (f2cl-lib:int-mul
+ (max (the f2cl-lib:integer4 30)
+ (the f2cl-lib:integer4 (f2cl-lib:int-mul 2 kexsh)))
+ (max (the f2cl-lib:integer4 10)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add (f2cl-lib:int-sub ihi ilo) 1)))))
+ (setf kbot ihi)
+ (f2cl-lib:fdo (it 1 (f2cl-lib:int-add it 1))
+ ((> it itmax) nil)
+ (tagbody
+ (if (< kbot ilo) (go label80))
+ (f2cl-lib:fdo (k kbot
+ (f2cl-lib:int-add k (f2cl-lib:int-sub 1)))
+ ((> k
+ (f2cl-lib:int-add ilo 1))
+ nil)
+ (tagbody
+ (if
+ (=
+ (f2cl-lib:fref h-%data% (k
+ (f2cl-lib:int-sub k 1)) ((1 ldh) (1 *))
+ h-%offset%)
+ zero)
+ (go label20))
+ label10))
+ (setf k ilo) label20 (setf ktop k)
+ (setf nh (f2cl-lib:int-add
+ (f2cl-lib:int-sub kbot ktop) 1))
+ (setf nwupbd
+ (min (the f2cl-lib:integer4 nh)
+ (the f2cl-lib:integer4 nwmax)))
+ (cond
+ ((< ndfl kexnw)
+ (setf nw
+ (min (the f2cl-lib:integer4 nwupbd)
+ (the f2cl-lib:integer4 nwr))))
+ (t
+ (setf nw
+ (min (the f2cl-lib:integer4 nwupbd)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-mul 2 nw))))))
+ (cond
+ ((< nw nwmax)
+ (cond ((>= nw (f2cl-lib:int-add nh
+ (f2cl-lib:int-sub 1)))
+ (setf nw nh))
+ (t (setf kwtop (f2cl-lib:int-add
+ (f2cl-lib:int-sub kbot nw) 1))
+ (if
+ (>
+ (cabs1
+ (f2cl-lib:fref h-%data% (kwtop
+ (f2cl-lib:int-sub kwtop 1))
+ ((1 ldh) (1 *)) h-%offset%))
+ (cabs1
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-sub kwtop 1)
+ (f2cl-lib:int-sub kwtop 2))
+ ((1 ldh) (1 *)) h-%offset%)))
+ (setf nw (f2cl-lib:int-add nw 1)))))))
+ (cond ((< ndfl kexnw) (setf ndec -1))
+ ((or (>= ndec 0) (>= nw nwupbd))
+ (setf ndec (f2cl-lib:int-add ndec 1))
+ (if (< (f2cl-lib:int-sub nw ndec) 2) (setf ndec 0))
+ (setf nw (f2cl-lib:int-sub nw ndec))))
+ (setf kv (f2cl-lib:int-add
+ (f2cl-lib:int-sub n nw) 1))
+ (setf kt (f2cl-lib:int-add nw 1))
+ (setf nho (f2cl-lib:int-add
+ (f2cl-lib:int-sub n nw 1 kt) 1))
+ (setf kwv (f2cl-lib:int-add nw 2))
+ (setf nve (f2cl-lib:int-add
+ (f2cl-lib:int-sub n nw kwv) 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)
+ (zlaqr2 wantt wantz n ktop kbot nw h ldh
+ iloz ihiz z ldz ls ld w
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (kv 1)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh nho
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (kv kt)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh nve
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (kwv 1)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh work lwork)
+ (declare
+ (ignore var-0 var-1 var-2 var-3 var-4 var-5
+ var-6 var-8 var-9 var-10
+ var-14 var-15 var-17 var-18 var-20 var-21
+ var-23 var-24))
+ (setf ldh var-7)
+ (setf ldz var-11)
+ (setf ls var-12)
+ (setf ld var-13)
+ (setf ldh var-16)
+ (setf ldh var-19)
+ (setf ldh var-22))
+ (setf kbot (f2cl-lib:int-sub kbot ld))
+ (setf ks (f2cl-lib:int-add
+ (f2cl-lib:int-sub kbot ls) 1))
+ (cond
+ ((or (= ld 0)
+ (and (<= (f2cl-lib:int-mul 100 ld)
+ (f2cl-lib:int-mul nw nibble))
+ (> (f2cl-lib:int-add kbot
+ (f2cl-lib:int-sub ktop) 1)
+ (min (the f2cl-lib:integer4 nmin)
+ (the f2cl-lib:integer4 nwmax)))))
+ (setf ns
+ (min (the f2cl-lib:integer4 nsmax)
+ (the f2cl-lib:integer4 nsr)
+ (the f2cl-lib:integer4
+ (max (the f2cl-lib:integer4 2)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-sub kbot ktop))))))
+ (setf ns (f2cl-lib:int-sub ns (mod ns 2)))
+ (cond
+ ((= (mod ndfl kexsh) 0)
+ (setf ks (f2cl-lib:int-add
+ (f2cl-lib:int-sub kbot ns) 1))
+ (f2cl-lib:fdo (i kbot (f2cl-lib:int-add i
+ (f2cl-lib:int-sub 2)))
+ ((> i
+ (f2cl-lib:int-add ks 1))
+ nil)
+ (tagbody
+ (setf (f2cl-lib:fref w-%data% (i)
+ ((1 *)) w-%offset%)
+ (+ (f2cl-lib:fref h-%data% (i i)
+ ((1 ldh) (1 *)) h-%offset%)
+ (* wilk1
+ (cabs1
+ (f2cl-lib:fref h-%data% (i
+ (f2cl-lib:int-sub i 1))
+ ((1 ldh) (1 *)) h-%offset%)))))
+ (setf
+ (f2cl-lib:fref w-%data%
+ ((f2cl-lib:int-sub i 1)) ((1 *))
+ w-%offset%)
+ (f2cl-lib:fref w-%data% (i) ((1 *))
+ w-%offset%))
+ label30)))
+ (t
+ (cond
+ ((<= (f2cl-lib:int-add kbot
+ (f2cl-lib:int-sub ks) 1)
+ (f2cl-lib:f2cl/ ns 2))
+ (setf ks (f2cl-lib:int-add
+ (f2cl-lib:int-sub kbot ns) 1))
+ (setf kt (f2cl-lib:int-add
+ (f2cl-lib:int-sub n ns) 1))
+ (zlacpy "A" ns ns
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (ks ks)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (kt 1)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh)
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5
+ var-6 var-7 var-8 var-9
+ var-10 var-11 var-12)
+ (zlahqr f2cl-lib:%false% f2cl-lib:%false%
+ ns 1 ns
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (kt 1)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh
+ (f2cl-lib:array-slice w-%data%
+ f2cl-lib:complex16 (ks) ((1 *))
+ w-%offset%)
+ 1 1 zdum 1 inf)
+ (declare
+ (ignore var-0 var-1 var-2 var-3 var-4
+ var-5 var-7 var-8 var-9
+ var-10 var-11))
+ (setf ldh var-6) (setf inf var-12))
+ (setf ks (f2cl-lib:int-add ks inf))
+ (cond
+ ((>= ks kbot)
+ (setf s
+ (+
+ (cabs1
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-sub kbot 1)
+ (f2cl-lib:int-sub kbot 1))
+ ((1 ldh) (1 *)) h-%offset%))
+ (cabs1
+ (f2cl-lib:fref h-%data% (kbot
+ (f2cl-lib:int-sub kbot 1))
+ ((1 ldh) (1 *)) h-%offset%))
+ (cabs1
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-sub kbot 1) kbot)
+ ((1 ldh) (1 *)) h-%offset%))
+ (cabs1
+ (f2cl-lib:fref h-%data% (kbot kbot)
+ ((1 ldh) (1 *))
+ h-%offset%))))
+ (setf aa
+ (/
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-sub kbot 1)
+ (f2cl-lib:int-sub kbot 1))
+ ((1 ldh) (1 *)) h-%offset%)
+ s))
+ (setf cc
+ (/
+ (f2cl-lib:fref h-%data% (kbot
+ (f2cl-lib:int-sub kbot 1))
+ ((1 ldh) (1 *)) h-%offset%)
+ s))
+ (setf bb
+ (/
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-sub kbot 1) kbot)
+ ((1 ldh) (1 *)) h-%offset%)
+ s))
+ (setf dd
+ (/
+ (f2cl-lib:fref h-%data% (kbot kbot)
+ ((1 ldh) (1 *)) h-%offset%)
+ s))
+ (setf tr2 (/ (+ aa dd) two))
+ (setf det (- (* (- aa tr2) (- dd tr2))
+ (* bb cc)))
+ (setf rtdisc (f2cl-lib:fsqrt (- det)))
+ (setf
+ (f2cl-lib:fref w-%data%
+ ((f2cl-lib:int-sub kbot 1)) ((1 *))
+ w-%offset%)
+ (* (+ tr2 rtdisc) s))
+ (setf (f2cl-lib:fref w-%data% (kbot)
+ ((1 *)) w-%offset%)
+ (* (- tr2 rtdisc) s))
+ (setf ks (f2cl-lib:int-sub kbot 1))))))
+ (cond
+ ((> (f2cl-lib:int-add kbot
+ (f2cl-lib:int-sub ks) 1) ns)
+ (tagbody (setf sorted f2cl-lib:%false%)
+ (f2cl-lib:fdo (k kbot (f2cl-lib:int-add k
+ (f2cl-lib:int-sub 1)))
+ ((>
+ k (f2cl-lib:int-add ks 1))
+ nil)
+ (tagbody (if sorted (go label60))
+ (setf sorted f2cl-lib:%true%)
+ (f2cl-lib:fdo (i ks
+ (f2cl-lib:int-add i 1))
+ ((> i
+ (f2cl-lib:int-add k
+ (f2cl-lib:int-sub 1)))
+ nil)
+ (tagbody
+ (cond
+ ((< (cabs1 (f2cl-lib:fref w (i)
+ ((1 *))))
+ (cabs1 (f2cl-lib:fref w
+ ((f2cl-lib:int-add i 1))
+ ((1 *)))))
+ (setf sorted f2cl-lib:%false%)
+ (setf swap (f2cl-lib:fref
+ w-%data% (i) ((1 *))
+ w-%offset%))
+ (setf (f2cl-lib:fref w-%data%
+ (i) ((1 *)) w-%offset%)
+ (f2cl-lib:fref w-%data%
+ ((f2cl-lib:int-add i 1)) ((1 *))
+ w-%offset%))
+ (setf
+ (f2cl-lib:fref w-%data%
+ ((f2cl-lib:int-add i 1)) ((1 *))
+ w-%offset%)
+ swap)))
+ label40))
+ label50))
+ label60)))))
+ (cond
+ ((= (f2cl-lib:int-add kbot
+ (f2cl-lib:int-sub ks) 1) 2)
+ (cond
+ ((<
+ (cabs1
+ (+ (f2cl-lib:fref w (kbot) ((1 *)))
+ (- (f2cl-lib:fref h (kbot kbot)
+ ((1 ldh) (1 *))))))
+ (cabs1
+ (+
+ (f2cl-lib:fref w
+ ((f2cl-lib:int-add kbot
+ (f2cl-lib:int-sub 1)))
+ ((1 *)))
+ (- (f2cl-lib:fref h (kbot kbot)
+ ((1 ldh) (1 *)))))))
+ (setf
+ (f2cl-lib:fref w-%data%
+ ((f2cl-lib:int-sub kbot 1)) ((1 *))
+ w-%offset%)
+ (f2cl-lib:fref w-%data% (kbot) ((1 *))
+ w-%offset%)))
+ (t
+ (setf (f2cl-lib:fref w-%data% (kbot)
+ ((1 *)) w-%offset%)
+ (f2cl-lib:fref w-%data%
+ ((f2cl-lib:int-sub kbot 1)) ((1 *))
+ w-%offset%))))))
+ (setf ns
+ (min (the f2cl-lib:integer4 ns)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add (f2cl-lib:int-sub kbot ks) 1))))
+ (setf ns (f2cl-lib:int-sub ns (mod ns 2)))
+ (setf ks (f2cl-lib:int-add
+ (f2cl-lib:int-sub kbot ns) 1))
+ (setf kdu (f2cl-lib:int-sub
+ (f2cl-lib:int-mul 3 ns) 3))
+ (setf ku (f2cl-lib:int-add
+ (f2cl-lib:int-sub n kdu) 1))
+ (setf kwh (f2cl-lib:int-add kdu 1))
+ (setf nho
+ (f2cl-lib:int-add
+ (f2cl-lib:int-sub
+ (f2cl-lib:int-add (f2cl-lib:int-sub n kdu) 1) 4
+ (f2cl-lib:int-add kdu 1))
+ 1))
+ (setf kwv (f2cl-lib:int-add kdu 4))
+ (setf nve
+ (f2cl-lib:int-add (f2cl-lib:int-sub n kdu kwv) 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)
+ (zlaqr5 wantt wantz kacc22 n ktop kbot ns
+ (f2cl-lib:array-slice w-%data%
+ f2cl-lib:complex16 (ks) ((1 *))
+ w-%offset%)
+ h ldh iloz ihiz z ldz work 3
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (ku 1)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh nve
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (kwv 1)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh nho
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (ku kwh)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh)
+ (declare
+ (ignore var-7 var-8 var-12 var-14 var-15
+ var-16 var-19 var-22))
+ (when var-0 (setf wantt var-0))
+ (when var-1 (setf wantz var-1))
+ (when var-2 (setf kacc22 var-2))
+ (when var-3 (setf n var-3))
+ (when var-4 (setf ktop var-4))
+ (when var-5 (setf kbot var-5))
+ (when var-6 (setf ns var-6))
+ (when var-9 (setf ldh var-9))
+ (when var-10 (setf iloz var-10))
+ (when var-11 (setf ihiz var-11))
+ (when var-13 (setf ldz var-13))
+ (when var-17 (setf ldh var-17))
+ (when var-18 (setf nve var-18))
+ (when var-20 (setf ldh var-20))
+ (when var-21 (setf nho var-21))
+ (when var-23 (setf ldh var-23)))))
+ (cond ((> ld 0) (setf ndfl 1))
+ (t (setf ndfl (f2cl-lib:int-add ndfl 1))))
+ label70))
+ (setf info kbot) label80)))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (f2cl-lib:dcmplx lwkopt 0))
+ end_label
+ (return
+ (values wantt wantz n ilo ihi nil ldh nil iloz ihiz nil ldz nil lwork
+ info)))))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -114146,7 +122285,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlaqr5.f}
* =====================================================================
SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S,
$ H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV,
@@ -114810,10 +122949,1593 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlaqr5}
-
+(let*
+ ((zero (coerce (f2cl-lib:cmplx 0.0d0 0.0d0) 'f2cl-lib:complex16))
+ (one (coerce (f2cl-lib:cmplx 1.0d0 0.0d0) 'f2cl-lib:complex16)) (rzero 0.0d0)
+ (rone 1.0d0))
+ (declare (type (f2cl-lib:complex16) zero) (type (f2cl-lib:complex16) one)
+ (type (double-float 0.0d0 0.0d0) rzero)
+ (type (double-float 1.0d0 1.0d0) rone) (ignorable zero one rzero rone))
+ (defun zlaqr5
+ (wantt wantz kacc22 n ktop kbot nshfts s h ldh iloz ihiz z ldz v ldv u ldu nv
+ wv ldwv nh wh ldwh)
+ (declare (type f2cl-lib:logical wantz wantt)
+ (type (f2cl-lib:integer4) ldwh nh ldwv nv ldu ldv ldz ihiz iloz ldh nshfts
+ kbot ktop n kacc22)
+ (type (array f2cl-lib:complex16 (*)) wh wv u v z h s))
+ (f2cl-lib:with-multi-array-data
+ ((s f2cl-lib:complex16 s-%data% s-%offset%)
+ (h f2cl-lib:complex16 h-%data% h-%offset%)
+ (z f2cl-lib:complex16 z-%data% z-%offset%)
+ (v f2cl-lib:complex16 v-%data% v-%offset%)
+ (u f2cl-lib:complex16 u-%data% u-%offset%)
+ (wv f2cl-lib:complex16 wv-%data% wv-%offset%)
+ (wh f2cl-lib:complex16 wh-%data% wh-%offset%))
+ (labels
+ ((cabs1 (cdum) (+ (abs (f2cl-lib:dble cdum))
+ (abs (f2cl-lib:dimag cdum)))))
+ (declare
+ (ftype (function (f2cl-lib:complex16)
+ (values double-float &rest t)) cabs1))
+ (prog
+ ((vt (make-array 3 :element-type 'f2cl-lib:complex16)) (accum nil)
+ (blk22 nil) (bmp22 nil) (i2 0) (i4 0) (incol 0) (j 0) (j2 0) (j4 0)
+ (jbot 0)
+ (jcol 0) (jlen 0) (jrow 0) (jtop 0) (k 0) (k1 0) (kdu 0) (kms 0)
+ (knz 0)
+ (krcol 0) (kzs 0) (m 0) (m22 0) (mbot 0) (mend 0) (mstart 0) (mtop 0)
+ (nbmps 0) (ndcol 0) (ns 0) (nu 0) (h11 0.0d0) (h12 0.0d0) (h21 0.0d0)
+ (h22 0.0d0) (safmax 0.0d0) (safmin 0.0d0) (scl 0.0d0) (smlnum 0.0d0)
+ (tst1 0.0d0) (tst2 0.0d0) (ulp 0.0d0) (alpha #C(0.0d0 0.0d0))
+ (beta #C(0.0d0 0.0d0)) (cdum #C(0.0d0 0.0d0))
+ (refsum #C(0.0d0 0.0d0)))
+ (declare (type (array f2cl-lib:complex16 (3)) vt)
+ (type f2cl-lib:logical bmp22 blk22 accum)
+ (type (f2cl-lib:integer4) nu ns ndcol nbmps mtop mstart
+ mend mbot m22 m kzs
+ krcol knz kms kdu k1 k jtop jrow jlen jcol jbot j4 j2 j incol i4 i2)
+ (type (double-float) ulp tst2 tst1 smlnum scl safmin safmax
+ h22 h21 h12 h11)
+ (type (f2cl-lib:complex16) refsum cdum beta alpha))
+ (if (< nshfts 2) (go end_label)) (if (>= ktop kbot) (go end_label))
+ (setf ns (f2cl-lib:int-sub nshfts (mod nshfts 2)))
+ (setf safmin (dlamch "SAFE MINIMUM")) (setf safmax (/ rone safmin))
+ (multiple-value-bind (var-0 var-1)
+ (dlabad safmin safmax) (declare (ignore))
+ (when var-0 (setf safmin var-0)) (when var-1 (setf safmax var-1)))
+ (setf ulp (dlamch "PRECISION"))
+ (setf smlnum (* safmin (/ (f2cl-lib:dble n) ulp)))
+ (setf accum (or (= kacc22 1) (= kacc22 2)))
+ (setf blk22 (and (> ns 2) (= kacc22 2)))
+ (if (<= (f2cl-lib:int-add ktop 2) kbot)
+ (setf
+ (f2cl-lib:fref h-%data% ((f2cl-lib:int-add ktop 2) ktop)
+ ((1 ldh) (1 *))
+ h-%offset%)
+ zero))
+ (setf nbmps (the f2cl-lib:integer4 (truncate ns 2)))
+ (setf kdu (f2cl-lib:int-sub (f2cl-lib:int-mul 6 nbmps) 3))
+ (f2cl-lib:fdo (incol
+ (f2cl-lib:int-add
+ (f2cl-lib:int-mul 3 (f2cl-lib:int-add 1
+ (f2cl-lib:int-sub nbmps))) ktop
+ (f2cl-lib:int-sub 1))
+ (f2cl-lib:int-add incol
+ (f2cl-lib:int-add (f2cl-lib:int-mul 3 nbmps)
+ (f2cl-lib:int-sub 2))))
+ ((>
+ incol (f2cl-lib:int-add kbot (f2cl-lib:int-sub 2)))
+ nil)
+ (tagbody (setf ndcol (f2cl-lib:int-add incol kdu))
+ (if accum
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (zlaset "ALL" kdu kdu zero one u ldu)
+ (declare (ignore var-0 var-5))
+ (when var-1 (setf kdu var-1))
+ (when var-2 (setf kdu var-2))
+ (when var-3 (setf zero var-3))
+ (when var-4 (setf one var-4))
+ (when var-6 (setf ldu var-6))))
+ (f2cl-lib:fdo (krcol incol (f2cl-lib:int-add krcol 1))
+ ((> krcol
+ (min
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add incol (f2cl-lib:int-mul 3 nbmps)
+ (f2cl-lib:int-sub 3)))
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add kbot (f2cl-lib:int-sub 2)))))
+ nil)
+ (tagbody
+ (setf mtop
+ (max 1 (+ (the f2cl-lib:integer4
+ (truncate (+ (- ktop 1 krcol) 2) 3)) 1)))
+ (setf mbot (min nbmps (the f2cl-lib:integer4
+ (truncate (- kbot krcol) 3))))
+ (setf m22 (f2cl-lib:int-add mbot 1))
+ (setf bmp22
+ (and (< mbot nbmps)
+ (= (f2cl-lib:int-add krcol
+ (f2cl-lib:int-mul 3 (f2cl-lib:int-sub m22 1)))
+ (f2cl-lib:int-sub kbot 2))))
+ (f2cl-lib:fdo (m mtop (f2cl-lib:int-add m 1))
+ ((> m mbot) nil)
+ (tagbody
+ (setf k
+ (f2cl-lib:int-add krcol
+ (f2cl-lib:int-mul 3 (f2cl-lib:int-sub m 1))))
+ (cond
+ ((= k (f2cl-lib:int-add ktop (f2cl-lib:int-sub 1)))
+ (zlaqr1 3
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 (ktop ktop)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh
+ (f2cl-lib:fref s-%data%
+ ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 m) 1))
+ ((1 *)) s-%offset%)
+ (f2cl-lib:fref s-%data%
+ ((f2cl-lib:int-mul 2 m)) ((1 *)) s-%offset%)
+ (f2cl-lib:array-slice v-%data%
+ f2cl-lib:complex16 (1 m) ((1 ldv) (1 *))
+ v-%offset%))
+ (setf alpha (f2cl-lib:fref v-%data% (1 m)
+ ((1 ldv) (1 *)) v-%offset%))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
+ (zlarfg 3 alpha
+ (f2cl-lib:array-slice v-%data%
+ f2cl-lib:complex16 (2 m)
+ ((1 ldv) (1 *)) v-%offset%)
+ 1
+ (f2cl-lib:array-slice v-%data%
+ f2cl-lib:complex16 (1 m)
+ ((1 ldv) (1 *)) v-%offset%))
+ (declare (ignore var-0 var-2 var-3 var-4))
+ (when var-1 (setf alpha var-1))))
+ (t
+ (setf beta
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1) k) ((1 ldh) (1 *))
+ h-%offset%))
+ (setf (f2cl-lib:fref v-%data% (2 m)
+ ((1 ldv) (1 *)) v-%offset%)
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 2) k) ((1 ldh) (1 *))
+ h-%offset%))
+ (setf (f2cl-lib:fref v-%data% (3 m)
+ ((1 ldv) (1 *)) v-%offset%)
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 3) k) ((1 ldh) (1 *))
+ h-%offset%))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
+ (zlarfg 3 beta
+ (f2cl-lib:array-slice v-%data%
+ f2cl-lib:complex16 (2 m)
+ ((1 ldv) (1 *)) v-%offset%)
+ 1
+ (f2cl-lib:array-slice v-%data%
+ f2cl-lib:complex16 (1 m)
+ ((1 ldv) (1 *)) v-%offset%))
+ (declare (ignore var-0 var-2 var-3 var-4))
+ (when var-1 (setf beta var-1)))
+ (cond
+ ((or
+ (/= (f2cl-lib:fref h
+ ((f2cl-lib:int-add k 3) k) ((1 ldh) (1 *)))
+ zero)
+ (/=
+ (f2cl-lib:fref h
+ ((f2cl-lib:int-add k 3) (f2cl-lib:int-add k 1))
+ ((1 ldh) (1 *)))
+ zero)
+ (=
+ (f2cl-lib:fref h
+ ((f2cl-lib:int-add k 3) (f2cl-lib:int-add k 2))
+ ((1 ldh) (1 *)))
+ zero))
+ (setf
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1) k) ((1 ldh) (1 *))
+ h-%offset%)
+ beta)
+ (setf
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 2) k) ((1 ldh) (1 *))
+ h-%offset%)
+ zero)
+ (setf
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 3) k) ((1 ldh) (1 *))
+ h-%offset%)
+ zero))
+ (t
+ (zlaqr1 3
+ (f2cl-lib:array-slice h-%data% f2cl-lib:complex16
+ ((+ k 1) (f2cl-lib:int-add k 1))
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh
+ (f2cl-lib:fref s-%data%
+ ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 m) 1))
+ ((1 *)) s-%offset%)
+ (f2cl-lib:fref s-%data%
+ ((f2cl-lib:int-mul 2 m)) ((1 *)) s-%offset%)
+ vt)
+ (setf alpha (f2cl-lib:fref vt (1) ((1 3))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4)
+ (zlarfg 3 alpha
+ (f2cl-lib:array-slice vt
+ f2cl-lib:complex16 (2) ((1 3))) 1
+ (f2cl-lib:array-slice vt
+ f2cl-lib:complex16 (1) ((1 3))))
+ (declare (ignore var-0 var-2 var-3 var-4))
+ (when var-1 (setf alpha var-1)))
+ (setf refsum
+ (coerce
+ (* (f2cl-lib:dconjg
+ (f2cl-lib:fref vt (1) ((1 3))))
+ (+
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1) k) ((1 ldh) (1 *))
+ h-%offset%)
+ (* (f2cl-lib:dconjg
+ (f2cl-lib:fref vt (2) ((1 3))))
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 2) k)
+ ((1 ldh) (1 *)) h-%offset%))))
+ 'f2cl-lib:complex16))
+ (cond
+ ((>
+ (+
+ (cabs1
+ (+ (f2cl-lib:fref h
+ ((f2cl-lib:int-add k 2) k)
+ ((1 ldh) (1 *)))
+ (* -1 refsum (f2cl-lib:fref vt (2)
+ ((1 3))))))
+ (cabs1 (* refsum (f2cl-lib:fref vt (3)
+ ((1 3))))))
+ (* ulp
+ (+ (cabs1 (f2cl-lib:fref h (k k)
+ ((1 ldh) (1 *))))
+ (cabs1
+ (f2cl-lib:fref h
+ ((f2cl-lib:int-add k 1)
+ (f2cl-lib:int-add k 1))
+ ((1 ldh) (1 *))))
+ (cabs1
+ (f2cl-lib:fref h
+ ((f2cl-lib:int-add k 2)
+ (f2cl-lib:int-add k 2))
+ ((1 ldh) (1 *)))))))
+ (setf
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1) k) ((1 ldh) (1 *))
+ h-%offset%)
+ beta)
+ (setf
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 2) k) ((1 ldh) (1 *))
+ h-%offset%)
+ zero)
+ (setf
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 3) k) ((1 ldh) (1 *))
+ h-%offset%)
+ zero))
+ (t
+ (setf
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1) k) ((1 ldh) (1 *))
+ h-%offset%)
+ (-
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1) k) ((1 ldh) (1 *))
+ h-%offset%)
+ refsum))
+ (setf
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 2) k) ((1 ldh) (1 *))
+ h-%offset%)
+ zero)
+ (setf
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 3) k) ((1 ldh) (1 *))
+ h-%offset%)
+ zero)
+ (setf (f2cl-lib:fref v-%data% (1 m)
+ ((1 ldv) (1 *)) v-%offset%)
+ (f2cl-lib:fref vt (1) ((1 3))))
+ (setf (f2cl-lib:fref v-%data% (2 m)
+ ((1 ldv) (1 *)) v-%offset%)
+ (f2cl-lib:fref vt (2) ((1 3))))
+ (setf (f2cl-lib:fref v-%data% (3 m)
+ ((1 ldv) (1 *)) v-%offset%)
+ (f2cl-lib:fref vt (3) ((1 3))))))))))
+ label10))
+ (setf k
+ (f2cl-lib:int-add krcol (f2cl-lib:int-mul 3
+ (f2cl-lib:int-sub m22 1))))
+ (cond
+ (bmp22
+ (cond
+ ((= k (f2cl-lib:int-add ktop (f2cl-lib:int-sub 1)))
+ (zlaqr1 2
+ (f2cl-lib:array-slice h-%data% f2cl-lib:complex16
+ ((+ k 1) (f2cl-lib:int-add k 1))
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh
+ (f2cl-lib:fref s-%data%
+ ((f2cl-lib:int-sub (f2cl-lib:int-mul 2 m22) 1))
+ ((1 *)) s-%offset%)
+ (f2cl-lib:fref s-%data%
+ ((f2cl-lib:int-mul 2 m22)) ((1 *)) s-%offset%)
+ (f2cl-lib:array-slice v-%data%
+ f2cl-lib:complex16 (1 m22)
+ ((1 ldv) (1 *)) v-%offset%))
+ (setf beta (f2cl-lib:fref v-%data% (1 m22)
+ ((1 ldv) (1 *)) v-%offset%))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
+ (zlarfg 2 beta
+ (f2cl-lib:array-slice v-%data%
+ f2cl-lib:complex16 (2 m22)
+ ((1 ldv) (1 *)) v-%offset%)
+ 1
+ (f2cl-lib:array-slice v-%data%
+ f2cl-lib:complex16 (1 m22)
+ ((1 ldv) (1 *)) v-%offset%))
+ (declare (ignore var-0 var-2 var-3 var-4))
+ (when var-1 (setf beta var-1))))
+ (t
+ (setf beta
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1) k) ((1 ldh) (1 *))
+ h-%offset%))
+ (setf (f2cl-lib:fref v-%data% (2 m22)
+ ((1 ldv) (1 *)) v-%offset%)
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 2) k) ((1 ldh) (1 *))
+ h-%offset%))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
+ (zlarfg 2 beta
+ (f2cl-lib:array-slice v-%data%
+ f2cl-lib:complex16 (2 m22)
+ ((1 ldv) (1 *)) v-%offset%)
+ 1
+ (f2cl-lib:array-slice v-%data%
+ f2cl-lib:complex16 (1 m22)
+ ((1 ldv) (1 *)) v-%offset%))
+ (declare (ignore var-0 var-2 var-3 var-4))
+ (when var-1 (setf beta var-1)))
+ (setf
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1) k) ((1 ldh) (1 *))
+ h-%offset%)
+ beta)
+ (setf
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 2) k) ((1 ldh) (1 *))
+ h-%offset%)
+ zero)))))
+ (cond
+ (accum
+ (setf jbot
+ (min (the f2cl-lib:integer4 ndcol)
+ (the f2cl-lib:integer4 kbot))))
+ (wantt (setf jbot n)) (t (setf jbot kbot)))
+ (f2cl-lib:fdo (j
+ (max (the f2cl-lib:integer4 ktop)
+ (the f2cl-lib:integer4 krcol))
+ (f2cl-lib:int-add j 1))
+ ((> j jbot) nil)
+ (tagbody
+ (setf mend
+ (min mbot
+ (the f2cl-lib:integer4
+ (truncate (+ (- j krcol) 2) 3))))
+ (f2cl-lib:fdo (m mtop (f2cl-lib:int-add m 1))
+ ((> m mend) nil)
+ (tagbody
+ (setf k
+ (f2cl-lib:int-add krcol
+ (f2cl-lib:int-mul 3 (f2cl-lib:int-sub m 1))))
+ (setf refsum
+ (coerce
+ (*
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref v-%data% (1 m)
+ ((1 ldv) (1 *)) v-%offset%))
+ (+
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1) j) ((1 ldh) (1 *))
+ h-%offset%)
+ (*
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref v-%data% (2 m)
+ ((1 ldv) (1 *)) v-%offset%))
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 2) j) ((1 ldh) (1 *))
+ h-%offset%))
+ (*
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref v-%data% (3 m)
+ ((1 ldv) (1 *)) v-%offset%))
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 3) j) ((1 ldh) (1 *))
+ h-%offset%))))
+ 'f2cl-lib:complex16))
+ (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%)
+ refsum))
+ (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%)
+ (* refsum (f2cl-lib:fref v-%data% (2 m)
+ ((1 ldv) (1 *)) v-%offset%))))
+ (setf
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 3) j) ((1 ldh) (1 *))
+ h-%offset%)
+ (-
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 3) j) ((1 ldh) (1 *))
+ h-%offset%)
+ (* refsum (f2cl-lib:fref v-%data% (3 m)
+ ((1 ldv) (1 *)) v-%offset%))))
+ label20))
+ label30))
+ (cond
+ (bmp22
+ (setf k
+ (f2cl-lib:int-add krcol
+ (f2cl-lib:int-mul 3 (f2cl-lib:int-sub m22 1))))
+ (f2cl-lib:fdo (j
+ (max (the f2cl-lib:integer4 (f2cl-lib:int-add k 1))
+ (the f2cl-lib:integer4 ktop))
+ (f2cl-lib:int-add j 1))
+ ((> j jbot) nil)
+ (tagbody
+ (setf refsum
+ (coerce
+ (*
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref v-%data% (1 m22)
+ ((1 ldv) (1 *)) v-%offset%))
+ (+
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1) j) ((1 ldh) (1 *))
+ h-%offset%)
+ (*
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref v-%data% (2 m22)
+ ((1 ldv) (1 *)) v-%offset%))
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 2) j) ((1 ldh) (1 *))
+ h-%offset%))))
+ 'f2cl-lib:complex16))
+ (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%)
+ refsum))
+ (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%)
+ (* refsum
+ (f2cl-lib:fref v-%data% (2 m22)
+ ((1 ldv) (1 *)) v-%offset%))))
+ label40))))
+ (cond
+ (accum
+ (setf jtop
+ (max (the f2cl-lib:integer4 ktop)
+ (the f2cl-lib:integer4 incol))))
+ (wantt (setf jtop 1)) (t (setf jtop ktop)))
+ (f2cl-lib:fdo (m mtop (f2cl-lib:int-add m 1))
+ ((> m mbot) nil)
+ (tagbody
+ (cond
+ ((/= (f2cl-lib:fref v (1 m) ((1 ldv) (1 *))) zero)
+ (setf k
+ (f2cl-lib:int-add krcol
+ (f2cl-lib:int-mul 3 (f2cl-lib:int-sub m 1))))
+ (f2cl-lib:fdo (j jtop (f2cl-lib:int-add j 1))
+ ((> j
+ (min (the f2cl-lib:integer4 kbot)
+ (the f2cl-lib:integer4 (f2cl-lib:int-add k 3))))
+ nil)
+ (tagbody
+ (setf refsum
+ (* (f2cl-lib:fref v-%data% (1 m)
+ ((1 ldv) (1 *)) v-%offset%)
+ (+
+ (f2cl-lib:fref h-%data% (j
+ (f2cl-lib:int-add k 1)) ((1 ldh) (1 *))
+ h-%offset%)
+ (* (f2cl-lib:fref v-%data% (2 m)
+ ((1 ldv) (1 *)) v-%offset%)
+ (f2cl-lib:fref h-%data% (j
+ (f2cl-lib:int-add k 2)) ((1 ldh) (1 *))
+ h-%offset%))
+ (* (f2cl-lib:fref v-%data% (3 m)
+ ((1 ldv) (1 *)) v-%offset%)
+ (f2cl-lib:fref h-%data% (j
+ (f2cl-lib:int-add k 3)) ((1 ldh) (1 *))
+ h-%offset%)))))
+ (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%)
+ refsum))
+ (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%)
+ (* refsum
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref v-%data% (2 m)
+ ((1 ldv) (1 *)) v-%offset%)))))
+ (setf
+ (f2cl-lib:fref h-%data% (j
+ (f2cl-lib:int-add k 3)) ((1 ldh) (1 *))
+ h-%offset%)
+ (-
+ (f2cl-lib:fref h-%data% (j
+ (f2cl-lib:int-add k 3)) ((1 ldh) (1 *))
+ h-%offset%)
+ (* refsum
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref v-%data% (3 m)
+ ((1 ldv) (1 *)) v-%offset%)))))
+ label50))
+ (cond
+ (accum (setf kms (f2cl-lib:int-sub k incol))
+ (f2cl-lib:fdo (j
+ (max (the f2cl-lib:integer4 1)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add ktop
+ (f2cl-lib:int-sub incol))))
+ (f2cl-lib:int-add j 1))
+ ((> j kdu) nil)
+ (tagbody
+ (setf refsum
+ (* (f2cl-lib:fref v-%data% (1 m)
+ ((1 ldv) (1 *)) v-%offset%)
+ (+
+ (f2cl-lib:fref u-%data% (j
+ (f2cl-lib:int-add kms 1))
+ ((1 ldu) (1 *)) u-%offset%)
+ (* (f2cl-lib:fref v-%data% (2 m)
+ ((1 ldv) (1 *)) v-%offset%)
+ (f2cl-lib:fref u-%data% (j
+ (f2cl-lib:int-add kms 2))
+ ((1 ldu) (1 *)) u-%offset%))
+ (* (f2cl-lib:fref v-%data% (3 m)
+ ((1 ldv) (1 *)) v-%offset%)
+ (f2cl-lib:fref u-%data% (j
+ (f2cl-lib:int-add kms 3))
+ ((1 ldu) (1 *)) u-%offset%)))))
+ (setf
+ (f2cl-lib:fref u-%data% (j
+ (f2cl-lib:int-add kms 1)) ((1 ldu) (1 *))
+ u-%offset%)
+ (-
+ (f2cl-lib:fref u-%data% (j
+ (f2cl-lib:int-add kms 1))
+ ((1 ldu) (1 *)) u-%offset%)
+ refsum))
+ (setf
+ (f2cl-lib:fref u-%data% (j
+ (f2cl-lib:int-add kms 2)) ((1 ldu) (1 *))
+ u-%offset%)
+ (-
+ (f2cl-lib:fref u-%data% (j
+ (f2cl-lib:int-add kms 2))
+ ((1 ldu) (1 *)) u-%offset%)
+ (* refsum
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref v-%data% (2 m)
+ ((1 ldv) (1 *)) v-%offset%)))))
+ (setf
+ (f2cl-lib:fref u-%data% (j
+ (f2cl-lib:int-add kms 3)) ((1 ldu) (1 *))
+ u-%offset%)
+ (-
+ (f2cl-lib:fref u-%data% (j
+ (f2cl-lib:int-add kms 3))
+ ((1 ldu) (1 *)) u-%offset%)
+ (* refsum
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref v-%data% (3 m) ((1 ldv)
+ (1 *)) v-%offset%)))))
+ label60)))
+ (wantz
+ (f2cl-lib:fdo (j iloz (f2cl-lib:int-add j 1))
+ ((> j ihiz) nil)
+ (tagbody
+ (setf refsum
+ (* (f2cl-lib:fref v-%data% (1 m)
+ ((1 ldv) (1 *)) v-%offset%)
+ (+
+ (f2cl-lib:fref z-%data% (j
+ (f2cl-lib:int-add k 1)) ((1 ldz) (1 *))
+ z-%offset%)
+ (* (f2cl-lib:fref v-%data% (2 m)
+ ((1 ldv) (1 *)) v-%offset%)
+ (f2cl-lib:fref z-%data% (j
+ (f2cl-lib:int-add k 2))
+ ((1 ldz) (1 *)) z-%offset%))
+ (* (f2cl-lib:fref v-%data% (3 m)
+ ((1 ldv) (1 *)) v-%offset%)
+ (f2cl-lib:fref z-%data% (j
+ (f2cl-lib:int-add k 3))
+ ((1 ldz) (1 *)) z-%offset%)))))
+ (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%)
+ refsum))
+ (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%)
+ (* refsum
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref v-%data% (2 m)
+ ((1 ldv) (1 *)) v-%offset%)))))
+ (setf
+ (f2cl-lib:fref z-%data% (j
+ (f2cl-lib:int-add k 3)) ((1 ldz) (1 *))
+ z-%offset%)
+ (-
+ (f2cl-lib:fref z-%data% (j
+ (f2cl-lib:int-add k 3)) ((1 ldz) (1 *))
+ z-%offset%)
+ (* refsum
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref v-%data% (3 m)
+ ((1 ldv) (1 *)) v-%offset%)))))
+ label70))))))
+ label80))
+ (setf k
+ (f2cl-lib:int-add krcol
+ (f2cl-lib:int-mul 3 (f2cl-lib:int-sub m22 1))))
+ (cond
+ (bmp22
+ (cond
+ ((/= (f2cl-lib:fref v (1 m22) ((1 ldv) (1 *))) zero)
+ (f2cl-lib:fdo (j jtop (f2cl-lib:int-add j 1))
+ ((> j
+ (min (the f2cl-lib:integer4 kbot)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add k 3))))
+ nil)
+ (tagbody
+ (setf refsum
+ (* (f2cl-lib:fref v-%data% (1 m22)
+ ((1 ldv) (1 *)) v-%offset%)
+ (+
+ (f2cl-lib:fref h-%data% (j
+ (f2cl-lib:int-add k 1)) ((1 ldh) (1 *))
+ h-%offset%)
+ (* (f2cl-lib:fref v-%data% (2 m22)
+ ((1 ldv) (1 *)) v-%offset%)
+ (f2cl-lib:fref h-%data% (j
+ (f2cl-lib:int-add k 2)) ((1 ldh) (1 *))
+ h-%offset%)))))
+ (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%)
+ refsum))
+ (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%)
+ (* refsum
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref v-%data% (2 m22)
+ ((1 ldv) (1 *)) v-%offset%)))))
+ label90))
+ (cond
+ (accum (setf kms (f2cl-lib:int-sub k incol))
+ (f2cl-lib:fdo (j
+ (max (the f2cl-lib:integer4 1)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add ktop
+ (f2cl-lib:int-sub incol))))
+ (f2cl-lib:int-add j 1))
+ ((> j kdu) nil)
+ (tagbody
+ (setf refsum
+ (* (f2cl-lib:fref v-%data% (1 m22)
+ ((1 ldv) (1 *)) v-%offset%)
+ (+
+ (f2cl-lib:fref u-%data% (j
+ (f2cl-lib:int-add kms 1))
+ ((1 ldu) (1 *)) u-%offset%)
+ (* (f2cl-lib:fref v-%data% (2 m22)
+ ((1 ldv) (1 *)) v-%offset%)
+ (f2cl-lib:fref u-%data% (j
+ (f2cl-lib:int-add kms 2))
+ ((1 ldu) (1 *)) u-%offset%)))))
+ (setf
+ (f2cl-lib:fref u-%data% (j
+ (f2cl-lib:int-add kms 1))
+ ((1 ldu) (1 *)) u-%offset%)
+ (-
+ (f2cl-lib:fref u-%data% (j
+ (f2cl-lib:int-add kms 1))
+ ((1 ldu) (1 *)) u-%offset%)
+ refsum))
+ (setf
+ (f2cl-lib:fref u-%data% (j
+ (f2cl-lib:int-add kms 2))
+ ((1 ldu) (1 *)) u-%offset%)
+ (-
+ (f2cl-lib:fref u-%data% (j
+ (f2cl-lib:int-add kms 2))
+ ((1 ldu) (1 *)) u-%offset%)
+ (* refsum
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref v-%data% (2 m22)
+ ((1 ldv) (1 *)) v-%offset%)))))
+ label100)))
+ (wantz
+ (f2cl-lib:fdo (j iloz (f2cl-lib:int-add j 1))
+ ((> j ihiz) nil)
+ (tagbody
+ (setf refsum
+ (* (f2cl-lib:fref v-%data% (1 m22)
+ ((1 ldv) (1 *)) v-%offset%)
+ (+
+ (f2cl-lib:fref z-%data% (j
+ (f2cl-lib:int-add k 1))
+ ((1 ldz) (1 *)) z-%offset%)
+ (* (f2cl-lib:fref v-%data% (2 m22)
+ ((1 ldv) (1 *)) v-%offset%)
+ (f2cl-lib:fref z-%data% (j
+ (f2cl-lib:int-add k 2))
+ ((1 ldz) (1 *)) z-%offset%)))))
+ (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%)
+ refsum))
+ (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%)
+ (* refsum
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref v-%data% (2 m22)
+ ((1 ldv) (1 *)) v-%offset%)))))
+ label110))))))))
+ (setf mstart mtop)
+ (if
+ (<
+ (f2cl-lib:int-add krcol
+ (f2cl-lib:int-mul 3 (f2cl-lib:int-sub mstart 1)))
+ ktop)
+ (setf mstart (f2cl-lib:int-add mstart 1)))
+ (setf mend mbot)
+ (if bmp22 (setf mend (f2cl-lib:int-add mend 1)))
+ (if (= krcol (f2cl-lib:int-sub kbot 2))
+ (setf mend (f2cl-lib:int-add mend 1)))
+ (f2cl-lib:fdo (m mstart (f2cl-lib:int-add m 1))
+ ((> m mend) nil)
+ (tagbody
+ (setf k
+ (min (the f2cl-lib:integer4 (f2cl-lib:int-sub kbot 1))
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add krcol
+ (f2cl-lib:int-mul 3 (f2cl-lib:int-sub m 1))))))
+ (cond
+ ((/= (f2cl-lib:fref h ((f2cl-lib:int-add k 1) k)
+ ((1 ldh) (1 *))) zero)
+ (setf tst1
+ (+ (cabs1 (f2cl-lib:fref h-%data% (k k)
+ ((1 ldh) (1 *)) h-%offset%))
+ (cabs1
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1)
+ (f2cl-lib:int-add k 1)) ((1 ldh) (1 *))
+ h-%offset%))))
+ (cond
+ ((= tst1 rzero)
+ (if (>= k (f2cl-lib:int-add ktop 1))
+ (setf tst1
+ (+ tst1
+ (cabs1
+ (f2cl-lib:fref h-%data% (k
+ (f2cl-lib:int-sub k 1)) ((1 ldh) (1 *))
+ h-%offset%)))))
+ (if (>= k (f2cl-lib:int-add ktop 2))
+ (setf tst1
+ (+ tst1
+ (cabs1
+ (f2cl-lib:fref h-%data% (k
+ (f2cl-lib:int-sub k 2)) ((1 ldh) (1 *))
+ h-%offset%)))))
+ (if (>= k (f2cl-lib:int-add ktop 3))
+ (setf tst1
+ (+ tst1
+ (cabs1
+ (f2cl-lib:fref h-%data% (k
+ (f2cl-lib:int-sub k 3)) ((1 ldh) (1 *))
+ h-%offset%)))))
+ (if (<= k (f2cl-lib:int-sub kbot 2))
+ (setf tst1
+ (+ tst1
+ (cabs1
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 2)
+ (f2cl-lib:int-add k 1)) ((1 ldh) (1 *))
+ h-%offset%)))))
+ (if (<= k (f2cl-lib:int-sub kbot 3))
+ (setf tst1
+ (+ tst1
+ (cabs1
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 3)
+ (f2cl-lib:int-add k 1)) ((1 ldh) (1 *))
+ h-%offset%)))))
+ (if (<= k (f2cl-lib:int-sub kbot 4))
+ (setf tst1
+ (+ tst1
+ (cabs1
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 4)
+ (f2cl-lib:int-add k 1)) ((1 ldh) (1 *))
+ h-%offset%)))))))
+ (cond
+ ((<=
+ (cabs1 (f2cl-lib:fref h
+ ((f2cl-lib:int-add k 1) k) ((1 ldh) (1 *))))
+ (max smlnum (* ulp tst1)))
+ (setf h12
+ (max
+ (cabs1
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1) k) ((1 ldh) (1 *))
+ h-%offset%))
+ (cabs1
+ (f2cl-lib:fref h-%data% (k
+ (f2cl-lib:int-add k 1)) ((1 ldh) (1 *))
+ h-%offset%))))
+ (setf h21
+ (min
+ (cabs1
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1) k) ((1 ldh) (1 *))
+ h-%offset%))
+ (cabs1
+ (f2cl-lib:fref h-%data% (k
+ (f2cl-lib:int-add k 1)) ((1 ldh) (1 *))
+ h-%offset%))))
+ (setf h11
+ (max
+ (cabs1
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1)
+ (f2cl-lib:int-add k 1)) ((1 ldh) (1 *))
+ h-%offset%))
+ (cabs1
+ (- (f2cl-lib:fref h-%data% (k k)
+ ((1 ldh) (1 *)) h-%offset%)
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1)
+ (f2cl-lib:int-add k 1)) ((1 ldh) (1 *))
+ h-%offset%)))))
+ (setf h22
+ (min
+ (cabs1
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1)
+ (f2cl-lib:int-add k 1)) ((1 ldh) (1 *))
+ h-%offset%))
+ (cabs1
+ (- (f2cl-lib:fref h-%data% (k k)
+ ((1 ldh) (1 *)) h-%offset%)
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1)
+ (f2cl-lib:int-add k 1)) ((1 ldh) (1 *))
+ h-%offset%)))))
+ (setf scl (+ h11 h12))
+ (setf tst2 (* h22 (/ h11 scl)))
+ (if
+ (or (= tst2 rzero)
+ (<= (* h21 (/ h12 scl))
+ (max smlnum (* ulp tst2))))
+ (setf
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 1) k) ((1 ldh) (1 *))
+ h-%offset%)
+ zero))))))
+ label120))
+ (setf mend
+ (min nbmps
+ (the f2cl-lib:integer4 (truncate (- kbot krcol 1) 3))))
+ (f2cl-lib:fdo (m mtop (f2cl-lib:int-add m 1))
+ ((> m mend) nil)
+ (tagbody
+ (setf k
+ (f2cl-lib:int-add krcol
+ (f2cl-lib:int-mul 3 (f2cl-lib:int-sub m 1))))
+ (setf refsum
+ (* (f2cl-lib:fref v-%data% (1 m) ((1 ldv) (1 *))
+ v-%offset%)
+ (f2cl-lib:fref v-%data% (3 m)
+ ((1 ldv) (1 *)) v-%offset%)
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 4) (f2cl-lib:int-add k 3))
+ ((1 ldh) (1 *)) h-%offset%)))
+ (setf
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 4) (f2cl-lib:int-add k 1))
+ ((1 ldh) (1 *)) h-%offset%)
+ (- refsum))
+ (setf
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 4) (f2cl-lib:int-add k 2))
+ ((1 ldh) (1 *)) h-%offset%)
+ (coerce
+ (* (- refsum)
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref v-%data% (2 m)
+ ((1 ldv) (1 *)) v-%offset%)))
+ 'f2cl-lib:complex16))
+ (setf
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 4) (f2cl-lib:int-add k 3))
+ ((1 ldh) (1 *)) h-%offset%)
+ (-
+ (f2cl-lib:fref h-%data%
+ ((f2cl-lib:int-add k 4) (f2cl-lib:int-add k 3))
+ ((1 ldh) (1 *)) h-%offset%)
+ (* refsum
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref v-%data% (3 m)
+ ((1 ldv) (1 *)) v-%offset%)))))
+ label130))
+ label140))
+ (cond
+ (accum
+ (cond (wantt (setf jtop 1) (setf jbot n))
+ (t (setf jtop ktop) (setf jbot kbot)))
+ (cond
+ ((or (not blk22) (< incol ktop)
+ (> ndcol kbot) (<= ns 2))
+ (setf k1
+ (max (the f2cl-lib:integer4 1)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-sub ktop incol))))
+ (setf nu
+ (f2cl-lib:int-add
+ (f2cl-lib:int-sub kdu
+ (max (the f2cl-lib:integer4 0)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-sub ndcol kbot)))
+ k1)
+ 1))
+ (f2cl-lib:fdo (jcol
+ (f2cl-lib:int-add
+ (min (the f2cl-lib:integer4 ndcol)
+ (the f2cl-lib:integer4 kbot)) 1)
+ (f2cl-lib:int-add jcol nh))
+ ((> jcol jbot) nil)
+ (tagbody
+ (setf jlen
+ (min (the f2cl-lib:integer4 nh)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add
+ (f2cl-lib:int-sub jbot jcol) 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)
+ (zgemm "C" "N" nu jlen nu one
+ (f2cl-lib:array-slice u-%data%
+ f2cl-lib:complex16 (k1 k1)
+ ((1 ldu) (1 *)) u-%offset%)
+ ldu
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 ((+ incol k1) jcol)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh zero wh ldwh)
+ (declare (ignore var-0 var-1 var-6 var-8
+ var-11))
+ (when var-2 (setf nu var-2))
+ (when var-3 (setf jlen var-3))
+ (when var-4 (setf nu var-4))
+ (when var-5 (setf one var-5))
+ (when var-7 (setf ldu var-7))
+ (when var-9 (setf ldh var-9))
+ (when var-10 (setf zero var-10))
+ (when var-12 (setf ldwh var-12)))
+ (zlacpy "ALL" nu jlen wh ldwh
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 ((+ incol k1) jcol)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh)
+ label150))
+ (f2cl-lib:fdo (jrow jtop (f2cl-lib:int-add jrow nv))
+ ((> jrow
+ (f2cl-lib:int-add
+ (max (the f2cl-lib:integer4 ktop)
+ (the f2cl-lib:integer4 incol))
+ (f2cl-lib:int-sub 1)))
+ nil)
+ (tagbody
+ (setf jlen
+ (min (the f2cl-lib:integer4 nv)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-sub
+ (max (the f2cl-lib:integer4 ktop)
+ (the f2cl-lib:integer4 incol))
+ jrow))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6
+ var-7 var-8 var-9 var-10
+ var-11 var-12)
+ (zgemm "N" "N" jlen nu nu one
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16
+ (jrow (f2cl-lib:int-add incol k1))
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh
+ (f2cl-lib:array-slice u-%data%
+ f2cl-lib:complex16 (k1 k1)
+ ((1 ldu) (1 *)) u-%offset%)
+ ldu zero wv ldwv)
+ (declare (ignore var-0 var-1 var-6
+ var-8 var-11))
+ (when var-2 (setf jlen var-2))
+ (when var-3 (setf nu var-3))
+ (when var-4 (setf nu var-4))
+ (when var-5 (setf one var-5))
+ (when var-7 (setf ldh var-7))
+ (when var-9 (setf ldu var-9))
+ (when var-10 (setf zero var-10))
+ (when var-12 (setf ldwv var-12)))
+ (zlacpy "ALL" jlen nu wv ldwv
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16
+ (jrow (f2cl-lib:int-add incol k1))
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh)
+ label160))
+ (cond
+ (wantz
+ (f2cl-lib:fdo (jrow iloz (f2cl-lib:int-add jrow nv))
+ ((> jrow ihiz)
+ nil)
+ (tagbody
+ (setf jlen
+ (min (the f2cl-lib:integer4 nv)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add
+ (f2cl-lib:int-sub ihiz jrow) 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)
+ (zgemm "N" "N" jlen nu nu one
+ (f2cl-lib:array-slice z-%data%
+ f2cl-lib:complex16
+ (jrow (f2cl-lib:int-add incol k1))
+ ((1 ldz) (1 *)) z-%offset%)
+ ldz
+ (f2cl-lib:array-slice u-%data%
+ f2cl-lib:complex16 (k1 k1)
+ ((1 ldu) (1 *)) u-%offset%)
+ ldu zero wv ldwv)
+ (declare (ignore var-0 var-1 var-6
+ var-8 var-11))
+ (when var-2 (setf jlen var-2))
+ (when var-3 (setf nu var-3))
+ (when var-4 (setf nu var-4))
+ (when var-5 (setf one var-5))
+ (when var-7 (setf ldz var-7))
+ (when var-9 (setf ldu var-9))
+ (when var-10 (setf zero var-10))
+ (when var-12 (setf ldwv var-12)))
+ (zlacpy "ALL" jlen nu wv ldwv
+ (f2cl-lib:array-slice z-%data%
+ f2cl-lib:complex16
+ (jrow (f2cl-lib:int-add incol k1))
+ ((1 ldz) (1 *)) z-%offset%)
+ ldz)
+ label170)))))
+ (t (setf i2 (the f2cl-lib:integer4
+ (truncate (+ kdu 1) 2)))
+ (setf i4 kdu)
+ (setf j2 (f2cl-lib:int-sub i4 i2))
+ (setf j4 kdu)
+ (setf kzs (f2cl-lib:int-sub j4 j2
+ (f2cl-lib:int-add ns 1)))
+ (setf knz (f2cl-lib:int-add ns 1))
+ (f2cl-lib:fdo (jcol
+ (f2cl-lib:int-add
+ (min (the f2cl-lib:integer4 ndcol)
+ (the f2cl-lib:integer4 kbot)) 1)
+ (f2cl-lib:int-add jcol nh))
+ ((> jcol jbot) nil)
+ (tagbody
+ (setf jlen
+ (min (the f2cl-lib:integer4 nh)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add
+ (f2cl-lib:int-sub jbot jcol) 1))))
+ (zlacpy "ALL" knz jlen
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16
+ ((+ incol 1 j2) jcol) ((1 ldh) (1 *))
+ h-%offset%)
+ ldh
+ (f2cl-lib:array-slice wh-%data%
+ f2cl-lib:complex16 ((+ kzs 1) 1)
+ ((1 ldwh) (1 *)) wh-%offset%)
+ ldwh)
+ (multiple-value-bind (var-0 var-1 var-2
+ var-3 var-4 var-5 var-6)
+ (zlaset "ALL" kzs jlen zero zero wh ldwh)
+ (declare (ignore var-0 var-5))
+ (when var-1 (setf kzs var-1))
+ (when var-2 (setf jlen var-2))
+ (when var-3 (setf zero var-3))
+ (when var-4 (setf zero var-4))
+ (when var-6 (setf ldwh var-6)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5
+ var-6 var-7 var-8 var-9 var-10)
+ (ztrmm "L" "U" "C" "N" knz jlen one
+ (f2cl-lib:array-slice u-%data%
+ f2cl-lib:complex16
+ ((+ j2 1) (f2cl-lib:int-add 1 kzs))
+ ((1 ldu) (1 *)) u-%offset%)
+ ldu
+ (f2cl-lib:array-slice wh-%data%
+ f2cl-lib:complex16 ((+ kzs 1) 1)
+ ((1 ldwh) (1 *)) wh-%offset%)
+ ldwh)
+ (declare (ignore var-0 var-1 var-2 var-3
+ var-7 var-9))
+ (when var-4 (setf knz var-4))
+ (when var-5 (setf jlen var-5))
+ (when var-6 (setf one var-6))
+ (when var-8 (setf ldu var-8))
+ (when var-10 (setf ldwh 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)
+ (zgemm "C" "N" i2 jlen j2 one u ldu
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 ((+ incol 1) jcol)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh one wh ldwh)
+ (declare (ignore var-0 var-1 var-6
+ var-8 var-11))
+ (when var-2 (setf i2 var-2))
+ (when var-3 (setf jlen var-3))
+ (when var-4 (setf j2 var-4))
+ (when var-5 (setf one var-5))
+ (when var-7 (setf ldu var-7))
+ (when var-9 (setf ldh var-9))
+ (when var-10 (setf one var-10))
+ (when var-12 (setf ldwh var-12)))
+ (zlacpy "ALL" j2 jlen
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 ((+ incol 1) jcol)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh
+ (f2cl-lib:array-slice wh-%data%
+ f2cl-lib:complex16 ((+ i2 1) 1)
+ ((1 ldwh) (1 *)) wh-%offset%)
+ ldwh)
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6
+ var-7 var-8 var-9 var-10)
+ (ztrmm "L" "L" "C" "N" j2 jlen one
+ (f2cl-lib:array-slice u-%data%
+ f2cl-lib:complex16
+ (1 (f2cl-lib:int-add i2 1))
+ ((1 ldu) (1 *)) u-%offset%)
+ ldu
+ (f2cl-lib:array-slice wh-%data%
+ f2cl-lib:complex16 ((+ i2 1) 1)
+ ((1 ldwh) (1 *)) wh-%offset%)
+ ldwh)
+ (declare (ignore var-0 var-1 var-2 var-3
+ var-7 var-9))
+ (when var-4 (setf j2 var-4))
+ (when var-5 (setf jlen var-5))
+ (when var-6 (setf one var-6))
+ (when var-8 (setf ldu var-8))
+ (when var-10 (setf ldwh 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)
+ (zgemm "C" "N" (f2cl-lib:int-sub i4 i2)
+ jlen (f2cl-lib:int-sub j4 j2)
+ one
+ (f2cl-lib:array-slice u-%data%
+ f2cl-lib:complex16
+ ((+ j2 1) (f2cl-lib:int-add i2 1))
+ ((1 ldu) (1 *)) u-%offset%)
+ ldu
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16
+ ((+ incol 1 j2) jcol) ((1 ldh) (1 *))
+ h-%offset%)
+ ldh one
+ (f2cl-lib:array-slice wh-%data%
+ f2cl-lib:complex16 ((+ i2 1) 1)
+ ((1 ldwh) (1 *)) wh-%offset%)
+ ldwh)
+ (declare (ignore var-0 var-1 var-2 var-4
+ var-6 var-8 var-11))
+ (when var-3 (setf jlen var-3))
+ (when var-5 (setf one var-5))
+ (when var-7 (setf ldu var-7))
+ (when var-9 (setf ldh var-9))
+ (when var-10 (setf one var-10))
+ (when var-12 (setf ldwh var-12)))
+ (zlacpy "ALL" kdu jlen wh ldwh
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16 ((+ incol 1) jcol)
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh)
+ label180))
+ (f2cl-lib:fdo (jrow jtop (f2cl-lib:int-add jrow nv))
+ ((> jrow
+ (f2cl-lib:int-add
+ (max (the f2cl-lib:integer4 incol)
+ (the f2cl-lib:integer4 ktop))
+ (f2cl-lib:int-sub 1)))
+ nil)
+ (tagbody
+ (setf jlen
+ (min (the f2cl-lib:integer4 nv)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-sub
+ (max (the f2cl-lib:integer4 incol)
+ (the f2cl-lib:integer4 ktop))
+ jrow))))
+ (zlacpy "ALL" jlen knz
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16
+ (jrow (f2cl-lib:int-add incol 1 j2))
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh
+ (f2cl-lib:array-slice wv-%data%
+ f2cl-lib:complex16
+ (1 (f2cl-lib:int-add 1 kzs))
+ ((1 ldwv) (1 *)) wv-%offset%)
+ ldwv)
+ (multiple-value-bind (var-0 var-1 var-2 var-3
+ var-4 var-5 var-6)
+ (zlaset "ALL" jlen kzs zero zero wv ldwv)
+ (declare (ignore var-0 var-5))
+ (when var-1 (setf jlen var-1))
+ (when var-2 (setf kzs var-2))
+ (when var-3 (setf zero var-3))
+ (when var-4 (setf zero var-4))
+ (when var-6 (setf ldwv var-6)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5
+ var-6 var-7 var-8 var-9 var-10)
+ (ztrmm "R" "U" "N" "N" jlen knz one
+ (f2cl-lib:array-slice u-%data%
+ f2cl-lib:complex16
+ ((+ j2 1) (f2cl-lib:int-add 1 kzs))
+ ((1 ldu) (1 *)) u-%offset%)
+ ldu
+ (f2cl-lib:array-slice wv-%data%
+ f2cl-lib:complex16
+ (1 (f2cl-lib:int-add 1 kzs))
+ ((1 ldwv) (1 *)) wv-%offset%)
+ ldwv)
+ (declare (ignore var-0 var-1 var-2 var-3
+ var-7 var-9))
+ (when var-4 (setf jlen var-4))
+ (when var-5 (setf knz var-5))
+ (when var-6 (setf one var-6))
+ (when var-8 (setf ldu var-8))
+ (when var-10 (setf ldwv 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)
+ (zgemm "N" "N" jlen i2 j2 one
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16
+ (jrow (f2cl-lib:int-add incol 1))
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh u ldu one wv ldwv)
+ (declare (ignore var-0 var-1 var-6
+ var-8 var-11))
+ (when var-2 (setf jlen var-2))
+ (when var-3 (setf i2 var-3))
+ (when var-4 (setf j2 var-4))
+ (when var-5 (setf one var-5))
+ (when var-7 (setf ldh var-7))
+ (when var-9 (setf ldu var-9))
+ (when var-10 (setf one var-10))
+ (when var-12 (setf ldwv var-12)))
+ (zlacpy "ALL" jlen j2
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16
+ (jrow (f2cl-lib:int-add incol 1))
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh
+ (f2cl-lib:array-slice wv-%data%
+ f2cl-lib:complex16
+ (1 (f2cl-lib:int-add 1 i2))
+ ((1 ldwv) (1 *)) wv-%offset%)
+ ldwv)
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6
+ var-7 var-8 var-9 var-10)
+ (ztrmm "R" "L" "N" "N" jlen
+ (f2cl-lib:int-sub i4 i2) one
+ (f2cl-lib:array-slice u-%data%
+ f2cl-lib:complex16
+ (1 (f2cl-lib:int-add i2 1))
+ ((1 ldu) (1 *)) u-%offset%)
+ ldu
+ (f2cl-lib:array-slice wv-%data%
+ f2cl-lib:complex16
+ (1 (f2cl-lib:int-add 1 i2))
+ ((1 ldwv) (1 *)) wv-%offset%)
+ ldwv)
+ (declare (ignore var-0 var-1 var-2 var-3
+ var-5 var-7 var-9))
+ (when var-4 (setf jlen var-4))
+ (when var-6 (setf one var-6))
+ (when var-8 (setf ldu var-8))
+ (when var-10 (setf ldwv 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)
+ (zgemm "N" "N" jlen
+ (f2cl-lib:int-sub i4 i2)
+ (f2cl-lib:int-sub j4 j2)
+ one
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16
+ (jrow (f2cl-lib:int-add incol 1 j2))
+ ((1 ldh) (1 *)) h-%offset%)
+ ldh
+ (f2cl-lib:array-slice u-%data%
+ f2cl-lib:complex16
+ ((+ j2 1) (f2cl-lib:int-add i2 1))
+ ((1 ldu) (1 *)) u-%offset%)
+ ldu one
+ (f2cl-lib:array-slice wv-%data%
+ f2cl-lib:complex16
+ (1 (f2cl-lib:int-add 1 i2)) ((1 ldwv)
+ (1 *)) wv-%offset%)
+ ldwv)
+ (declare (ignore var-0 var-1 var-3 var-4
+ var-6 var-8 var-11))
+ (when var-2 (setf jlen var-2))
+ (when var-5 (setf one var-5))
+ (when var-7 (setf ldh var-7))
+ (when var-9 (setf ldu var-9))
+ (when var-10 (setf one var-10))
+ (when var-12 (setf ldwv var-12)))
+ (zlacpy "ALL" jlen kdu wv ldwv
+ (f2cl-lib:array-slice h-%data%
+ f2cl-lib:complex16
+ (jrow (f2cl-lib:int-add incol 1)) ((1 ldh)
+ (1 *)) h-%offset%)
+ ldh)
+ label190))
+ (cond
+ (wantz
+ (f2cl-lib:fdo (jrow iloz (f2cl-lib:int-add jrow nv))
+ ((> jrow ihiz)
+ nil)
+ (tagbody
+ (setf jlen
+ (min (the f2cl-lib:integer4 nv)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add
+ (f2cl-lib:int-sub ihiz jrow) 1))))
+ (zlacpy "ALL" jlen knz
+ (f2cl-lib:array-slice z-%data%
+ f2cl-lib:complex16
+ (jrow (f2cl-lib:int-add incol 1 j2))
+ ((1 ldz) (1 *)) z-%offset%)
+ ldz
+ (f2cl-lib:array-slice wv-%data%
+ f2cl-lib:complex16
+ (1 (f2cl-lib:int-add 1 kzs))
+ ((1 ldwv) (1 *)) wv-%offset%)
+ ldwv)
+ (multiple-value-bind (var-0 var-1 var-2
+ var-3 var-4 var-5 var-6)
+ (zlaset "ALL" jlen kzs zero zero wv ldwv)
+ (declare (ignore var-0 var-5))
+ (when var-1 (setf jlen var-1))
+ (when var-2 (setf kzs var-2))
+ (when var-3 (setf zero var-3))
+ (when var-4 (setf zero var-4))
+ (when var-6 (setf ldwv var-6)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5
+ var-6 var-7 var-8 var-9 var-10)
+ (ztrmm "R" "U" "N" "N" jlen knz one
+ (f2cl-lib:array-slice u-%data%
+ f2cl-lib:complex16
+ ((+ j2 1) (f2cl-lib:int-add 1 kzs))
+ ((1 ldu) (1 *)) u-%offset%)
+ ldu
+ (f2cl-lib:array-slice wv-%data%
+ f2cl-lib:complex16
+ (1 (f2cl-lib:int-add 1 kzs))
+ ((1 ldwv) (1 *)) wv-%offset%)
+ ldwv)
+ (declare (ignore
+ var-0 var-1 var-2 var-3 var-7 var-9))
+ (when var-4 (setf jlen var-4))
+ (when var-5 (setf knz var-5))
+ (when var-6 (setf one var-6))
+ (when var-8 (setf ldu var-8))
+ (when var-10 (setf ldwv 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)
+ (zgemm "N" "N" jlen i2 j2 one
+ (f2cl-lib:array-slice z-%data%
+ f2cl-lib:complex16
+ (jrow (f2cl-lib:int-add incol 1))
+ ((1 ldz) (1 *)) z-%offset%)
+ ldz u ldu one wv ldwv)
+ (declare (ignore var-0 var-1 var-6
+ var-8 var-11))
+ (when var-2 (setf jlen var-2))
+ (when var-3 (setf i2 var-3))
+ (when var-4 (setf j2 var-4))
+ (when var-5 (setf one var-5))
+ (when var-7 (setf ldz var-7))
+ (when var-9 (setf ldu var-9))
+ (when var-10 (setf one var-10))
+ (when var-12 (setf ldwv var-12)))
+ (zlacpy "ALL" jlen j2
+ (f2cl-lib:array-slice z-%data%
+ f2cl-lib:complex16
+ (jrow (f2cl-lib:int-add incol 1))
+ ((1 ldz) (1 *)) z-%offset%)
+ ldz
+ (f2cl-lib:array-slice wv-%data%
+ f2cl-lib:complex16
+ (1 (f2cl-lib:int-add 1 i2))
+ ((1 ldwv) (1 *)) wv-%offset%)
+ ldwv)
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5
+ var-6 var-7 var-8 var-9 var-10)
+ (ztrmm "R" "L" "N" "N" jlen
+ (f2cl-lib:int-sub i4 i2) one
+ (f2cl-lib:array-slice u-%data%
+ f2cl-lib:complex16
+ (1 (f2cl-lib:int-add i2 1))
+ ((1 ldu) (1 *)) u-%offset%)
+ ldu
+ (f2cl-lib:array-slice wv-%data%
+ f2cl-lib:complex16
+ (1 (f2cl-lib:int-add 1 i2))
+ ((1 ldwv) (1 *)) wv-%offset%)
+ ldwv)
+ (declare (ignore var-0 var-1 var-2 var-3
+ var-5 var-7 var-9))
+ (when var-4 (setf jlen var-4))
+ (when var-6 (setf one var-6))
+ (when var-8 (setf ldu var-8))
+ (when var-10 (setf ldwv 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)
+ (zgemm "N" "N" jlen (f2cl-lib:int-sub i4 i2)
+ (f2cl-lib:int-sub j4 j2) one
+ (f2cl-lib:array-slice z-%data%
+ f2cl-lib:complex16
+ (jrow (f2cl-lib:int-add incol 1 j2))
+ ((1 ldz) (1 *)) z-%offset%)
+ ldz
+ (f2cl-lib:array-slice u-%data%
+ f2cl-lib:complex16
+ ((+ j2 1) (f2cl-lib:int-add i2 1))
+ ((1 ldu) (1 *)) u-%offset%)
+ ldu one
+ (f2cl-lib:array-slice wv-%data%
+ f2cl-lib:complex16
+ (1 (f2cl-lib:int-add 1 i2)) ((1 ldwv)
+ (1 *)) wv-%offset%)
+ ldwv)
+ (declare (ignore var-0 var-1 var-3 var-4
+ var-6 var-8 var-11))
+ (when var-2 (setf jlen var-2))
+ (when var-5 (setf one var-5))
+ (when var-7 (setf ldz var-7))
+ (when var-9 (setf ldu var-9))
+ (when var-10 (setf one var-10))
+ (when var-12 (setf ldwv var-12)))
+ (zlacpy "ALL" jlen kdu wv ldwv
+ (f2cl-lib:array-slice
+ z-%data% f2cl-lib:complex16
+ (jrow (f2cl-lib:int-add incol 1))
+ ((1 ldz) (1 *)) z-%offset%)
+ ldz)
+ label200))))))))
+ label210))
+ end_label
+ (return
+ (values nil nil nil nil nil nil nil nil nil ldh nil nil nil
+ ldz nil nil nil
+ ldu nil nil ldwv nil nil ldwh)))))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -115000,7 +124722,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlarfb.f}
* =====================================================================
SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
@@ -115583,10 +125305,953 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlarfb}
-
+(let* ((one (coerce (f2cl-lib:cmplx 1.0d0 0.0d0) 'f2cl-lib:complex16)))
+ (declare (type (f2cl-lib:complex16) one) (ignorable one))
+ (defun zlarfb (side trans direct storev m n k v ldv t$ ldt c ldc work ldwork)
+ (declare (type (simple-array character (*)) storev direct trans side)
+ (type (f2cl-lib:integer4) ldwork ldc ldt ldv k n m)
+ (type (array f2cl-lib:complex16 (*)) work c t$ v))
+ (f2cl-lib:with-multi-array-data
+ ((v f2cl-lib:complex16 v-%data% v-%offset%)
+ (t$ f2cl-lib:complex16 t$-%data% t$-%offset%)
+ (c f2cl-lib:complex16 c-%data% c-%offset%)
+ (work f2cl-lib:complex16 work-%data% work-%offset%)
+ (side character side-%data% side-%offset%)
+ (trans character trans-%data% trans-%offset%)
+ (direct character direct-%data% direct-%offset%)
+ (storev character storev-%data% storev-%offset%))
+ (prog
+ ((i 0) (j 0) (lastv 0) (lastc 0)
+ (transt (make-array '(1) :element-type 'character
+ :initial-element #\space)))
+ (declare (type (f2cl-lib:integer4) lastc lastv j i)
+ (type (simple-array character (1)) transt))
+ (if (or (<= m 0) (<= n 0)) (go end_label))
+ (cond
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame trans "N")
+ (declare (ignore var-1)) (when var-0 (setf trans var-0)) ret-val)
+ (f2cl-lib:f2cl-set-string transt "C" (string 1)))
+ (t (f2cl-lib:f2cl-set-string transt "N" (string 1))))
+ (cond
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame storev "C")
+ (declare (ignore var-1)) (when var-0 (setf storev var-0)) ret-val)
+ (cond
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame direct "F")
+ (declare (ignore var-1)) (when var-0 (setf direct var-0)) ret-val)
+ (cond
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame side "L")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val)
+ (setf lastv
+ (max (the f2cl-lib:integer4 k)
+ (the f2cl-lib:integer4 (ilazlr m k v ldv))))
+ (setf lastc (ilazlc lastv n c ldc))
+ (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)
+ (zcopy lastc
+ (f2cl-lib:array-slice c-%data%
+ f2cl-lib:complex16 (j 1)
+ ((1 ldc) (1 *)) c-%offset%)
+ ldc
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 (1 j)
+ ((1 ldwork) (1 *)) work-%offset%)
+ 1)
+ (declare (ignore var-1 var-3 var-4))
+ (when var-0 (setf lastc var-0))
+ (when var-2 (setf ldc var-2)))
+ (zlacgv lastc
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 (1 j)
+ ((1 ldwork) (1 *)) work-%offset%)
+ 1)
+ label10))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Lower" "No transpose" "Unit"
+ lastc k one v ldv work
+ ldwork)
+ (declare (ignore var-0 var-1 var-2 var-3 var-7 var-9))
+ (when var-4 (setf lastc var-4)) (when var-5 (setf k var-5))
+ (when var-6 (setf one var-6)) (when var-8 (setf ldv var-8))
+ (when var-10 (setf ldwork var-10)))
+ (cond
+ ((> lastv 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)
+ (zgemm "Conjugate transpose" "No transpose" lastc k
+ (f2cl-lib:int-sub lastv k) one
+ (f2cl-lib:array-slice c-%data% f2cl-lib:complex16 ((+ k 1) 1)
+ ((1 ldc) (1 *)) c-%offset%)
+ ldc
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16 ((+ k 1) 1)
+ ((1 ldv) (1 *)) v-%offset%)
+ ldv one work ldwork)
+ (declare (ignore var-0 var-1 var-4 var-6 var-8 var-11))
+ (when var-2 (setf lastc var-2)) (when var-3 (setf k var-3))
+ (when var-5 (setf one var-5)) (when var-7 (setf ldc var-7))
+ (when var-9 (setf ldv var-9)) (when var-10 (setf one var-10))
+ (when var-12 (setf ldwork var-12)))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Upper" transt "Non-unit" lastc k one t$ ldt work
+ ldwork)
+ (declare (ignore var-0 var-1 var-3 var-7 var-9))
+ (when var-2 (setf transt var-2)) (when var-4 (setf lastc var-4))
+ (when var-5 (setf k var-5)) (when var-6 (setf one var-6))
+ (when var-8 (setf ldt var-8))
+ (when var-10 (setf ldwork var-10)))
+ (cond
+ ((> m 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)
+ (zgemm "No transpose" "Conjugate transpose"
+ (f2cl-lib:int-sub lastv k) lastc k (- one)
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16 ((+ k 1) 1)
+ ((1 ldv) (1 *)) v-%offset%)
+ ldv work ldwork one
+ (f2cl-lib:array-slice c-%data% f2cl-lib:complex16 ((+ k 1) 1)
+ ((1 ldc) (1 *)) c-%offset%)
+ ldc)
+ (declare (ignore var-0 var-1 var-2 var-5 var-6 var-8 var-11))
+ (when var-3 (setf lastc var-3)) (when var-4 (setf k var-4))
+ (when var-7 (setf ldv var-7)) (when var-9 (setf ldwork var-9))
+ (when var-10 (setf one var-10))
+ (when var-12 (setf ldc var-12)))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Lower" "Conjugate transpose" "Unit"
+ lastc k one v ldv
+ work ldwork)
+ (declare (ignore var-0 var-1 var-2 var-3 var-7 var-9))
+ (when var-4 (setf lastc var-4)) (when var-5 (setf k var-5))
+ (when var-6 (setf one var-6)) (when var-8 (setf ldv var-8))
+ (when var-10 (setf ldwork var-10)))
+ (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 lastc) nil)
+ (tagbody
+ (setf (f2cl-lib:fref c-%data% (j i)
+ ((1 ldc) (1 *)) c-%offset%)
+ (coerce
+ (- (f2cl-lib:fref c-%data% (j i)
+ ((1 ldc) (1 *)) c-%offset%)
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref work-%data% (i j)
+ ((1 ldwork) (1 *))
+ work-%offset%)))
+ 'f2cl-lib:complex16))
+ label20))
+ label30)))
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame side "R")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val)
+ (setf lastv
+ (max (the f2cl-lib:integer4 k)
+ (the f2cl-lib:integer4 (ilazlr n k v ldv))))
+ (setf lastc (ilazlr m lastv c ldc))
+ (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)
+ (zcopy lastc
+ (f2cl-lib:array-slice c-%data%
+ f2cl-lib:complex16 (1 j)
+ ((1 ldc) (1 *)) c-%offset%)
+ 1
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 (1 j)
+ ((1 ldwork) (1 *)) work-%offset%)
+ 1)
+ (declare (ignore var-1 var-2 var-3 var-4))
+ (when var-0 (setf lastc var-0)))
+ label40))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Lower" "No transpose" "Unit"
+ lastc k one v ldv work
+ ldwork)
+ (declare (ignore var-0 var-1 var-2 var-3 var-7 var-9))
+ (when var-4 (setf lastc var-4)) (when var-5 (setf k var-5))
+ (when var-6 (setf one var-6)) (when var-8 (setf ldv var-8))
+ (when var-10 (setf ldwork var-10)))
+ (cond
+ ((> lastv 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)
+ (zgemm "No transpose" "No transpose" lastc k
+ (f2cl-lib:int-sub lastv k) one
+ (f2cl-lib:array-slice c-%data% f2cl-lib:complex16
+ (1 (f2cl-lib:int-add k 1)) ((1 ldc) (1 *)) c-%offset%)
+ ldc
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16 ((+ k 1) 1)
+ ((1 ldv) (1 *)) v-%offset%)
+ ldv one work ldwork)
+ (declare (ignore var-0 var-1 var-4 var-6 var-8 var-11))
+ (when var-2 (setf lastc var-2)) (when var-3 (setf k var-3))
+ (when var-5 (setf one var-5)) (when var-7 (setf ldc var-7))
+ (when var-9 (setf ldv var-9)) (when var-10 (setf one var-10))
+ (when var-12 (setf ldwork var-12)))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Upper" trans "Non-unit"
+ lastc k one t$ ldt work ldwork)
+ (declare (ignore var-0 var-1 var-3 var-7 var-9))
+ (when var-2 (setf trans var-2)) (when var-4 (setf lastc var-4))
+ (when var-5 (setf k var-5)) (when var-6 (setf one var-6))
+ (when var-8 (setf ldt var-8))
+ (when var-10 (setf ldwork var-10)))
+ (cond
+ ((> lastv 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)
+ (zgemm "No transpose" "Conjugate transpose" lastc
+ (f2cl-lib:int-sub lastv k) k (- one) work ldwork
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16 ((+ k 1) 1)
+ ((1 ldv) (1 *)) v-%offset%)
+ ldv one
+ (f2cl-lib:array-slice c-%data% f2cl-lib:complex16
+ (1 (f2cl-lib:int-add k 1)) ((1 ldc) (1 *)) c-%offset%)
+ ldc)
+ (declare (ignore var-0 var-1 var-3 var-5 var-6 var-8 var-11))
+ (when var-2 (setf lastc var-2)) (when var-4 (setf k var-4))
+ (when var-7 (setf ldwork var-7)) (when var-9 (setf ldv var-9))
+ (when var-10 (setf one var-10))
+ (when var-12 (setf ldc var-12)))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Lower" "Conjugate transpose" "Unit"
+ lastc k one v ldv
+ work ldwork)
+ (declare (ignore var-0 var-1 var-2 var-3 var-7 var-9))
+ (when var-4 (setf lastc var-4)) (when var-5 (setf k var-5))
+ (when var-6 (setf one var-6)) (when var-8 (setf ldv var-8))
+ (when var-10 (setf ldwork var-10)))
+ (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 lastc) 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%)))
+ label50))
+ label60)))))
+ (t
+ (cond
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame side "L")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val)
+ (setf lastv
+ (max (the f2cl-lib:integer4 k)
+ (the f2cl-lib:integer4 (ilazlr m k v ldv))))
+ (setf lastc (ilazlc lastv n c ldc))
+ (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)
+ (zcopy lastc
+ (f2cl-lib:array-slice c-%data%
+ f2cl-lib:complex16
+ ((+ lastv (f2cl-lib:int-sub k) j) 1)
+ ((1 ldc) (1 *)) c-%offset%)
+ ldc
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 (1 j)
+ ((1 ldwork) (1 *)) work-%offset%)
+ 1)
+ (declare (ignore var-1 var-3 var-4))
+ (when var-0 (setf lastc var-0))
+ (when var-2 (setf ldc var-2)))
+ (zlacgv lastc
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 (1 j)
+ ((1 ldwork) (1 *)) work-%offset%)
+ 1)
+ label70))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Upper" "No transpose" "Unit" lastc k one
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ ((+ lastv (f2cl-lib:int-sub k) 1) 1)
+ ((1 ldv) (1 *)) v-%offset%)
+ ldv work ldwork)
+ (declare (ignore var-0 var-1 var-2 var-3 var-7 var-9))
+ (when var-4 (setf lastc var-4)) (when var-5 (setf k var-5))
+ (when var-6 (setf one var-6)) (when var-8 (setf ldv var-8))
+ (when var-10 (setf ldwork var-10)))
+ (cond
+ ((> lastv 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)
+ (zgemm "Conjugate transpose" "No transpose" lastc k
+ (f2cl-lib:int-sub lastv k) one c ldc v ldv one work ldwork)
+ (declare (ignore var-0 var-1 var-4 var-6 var-8 var-11))
+ (when var-2 (setf lastc var-2)) (when var-3 (setf k var-3))
+ (when var-5 (setf one var-5)) (when var-7 (setf ldc var-7))
+ (when var-9 (setf ldv var-9)) (when var-10 (setf one var-10))
+ (when var-12 (setf ldwork var-12)))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Lower" transt "Non-unit" lastc k one t$ ldt work
+ ldwork)
+ (declare (ignore var-0 var-1 var-3 var-7 var-9))
+ (when var-2 (setf transt var-2)) (when var-4 (setf lastc var-4))
+ (when var-5 (setf k var-5)) (when var-6 (setf one var-6))
+ (when var-8 (setf ldt var-8))
+ (when var-10 (setf ldwork var-10)))
+ (cond
+ ((> lastv 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)
+ (zgemm "No transpose" "Conjugate transpose"
+ (f2cl-lib:int-sub lastv k) lastc k
+ (- one) v ldv work ldwork one c
+ ldc)
+ (declare (ignore var-0 var-1 var-2 var-5 var-6 var-8 var-11))
+ (when var-3 (setf lastc var-3)) (when var-4 (setf k var-4))
+ (when var-7 (setf ldv var-7)) (when var-9 (setf ldwork var-9))
+ (when var-10 (setf one var-10))
+ (when var-12 (setf ldc var-12)))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Upper" "Conjugate transpose" "Unit" lastc k one
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ ((+ lastv (f2cl-lib:int-sub k) 1) 1)
+ ((1 ldv) (1 *)) v-%offset%)
+ ldv work ldwork)
+ (declare (ignore var-0 var-1 var-2 var-3 var-7 var-9))
+ (when var-4 (setf lastc var-4)) (when var-5 (setf k var-5))
+ (when var-6 (setf one var-6)) (when var-8 (setf ldv var-8))
+ (when var-10 (setf ldwork var-10)))
+ (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 lastc) nil)
+ (tagbody
+ (setf
+ (f2cl-lib:fref c-%data%
+ ((f2cl-lib:int-add
+ (f2cl-lib:int-sub lastv k) j) i)
+ ((1 ldc) (1 *))
+ c-%offset%)
+ (coerce
+ (-
+ (f2cl-lib:fref c-%data%
+ ((f2cl-lib:int-add
+ (f2cl-lib:int-sub lastv k) j) i)
+ ((1 ldc) (1 *)) c-%offset%)
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref work-%data% (i j)
+ ((1 ldwork) (1 *))
+ work-%offset%)))
+ 'f2cl-lib:complex16))
+ label80))
+ label90)))
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame side "R")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val)
+ (setf lastv
+ (max (the f2cl-lib:integer4 k)
+ (the f2cl-lib:integer4 (ilazlr n k v ldv))))
+ (setf lastc (ilazlr m lastv c ldc))
+ (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)
+ (zcopy lastc
+ (f2cl-lib:array-slice c-%data%
+ f2cl-lib:complex16
+ (1 (f2cl-lib:int-add
+ (f2cl-lib:int-sub lastv k) j))
+ ((1 ldc) (1 *))
+ c-%offset%)
+ 1
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 (1 j)
+ ((1 ldwork) (1 *)) work-%offset%)
+ 1)
+ (declare (ignore var-1 var-2 var-3 var-4))
+ (when var-0 (setf lastc var-0)))
+ label100))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Upper" "No transpose" "Unit" lastc k one
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ ((+ lastv (f2cl-lib:int-sub k) 1) 1)
+ ((1 ldv) (1 *)) v-%offset%)
+ ldv work ldwork)
+ (declare (ignore var-0 var-1 var-2 var-3 var-7 var-9))
+ (when var-4 (setf lastc var-4)) (when var-5 (setf k var-5))
+ (when var-6 (setf one var-6)) (when var-8 (setf ldv var-8))
+ (when var-10 (setf ldwork var-10)))
+ (cond
+ ((> lastv 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)
+ (zgemm "No transpose" "No transpose" lastc k
+ (f2cl-lib:int-sub lastv k) one c ldc v ldv one work ldwork)
+ (declare (ignore var-0 var-1 var-4 var-6 var-8 var-11))
+ (when var-2 (setf lastc var-2)) (when var-3 (setf k var-3))
+ (when var-5 (setf one var-5)) (when var-7 (setf ldc var-7))
+ (when var-9 (setf ldv var-9)) (when var-10 (setf one var-10))
+ (when var-12 (setf ldwork var-12)))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Lower" trans "Non-unit"
+ lastc k one t$ ldt work ldwork)
+ (declare (ignore var-0 var-1 var-3 var-7 var-9))
+ (when var-2 (setf trans var-2)) (when var-4 (setf lastc var-4))
+ (when var-5 (setf k var-5)) (when var-6 (setf one var-6))
+ (when var-8 (setf ldt var-8))
+ (when var-10 (setf ldwork var-10)))
+ (cond
+ ((> lastv 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)
+ (zgemm "No transpose" "Conjugate transpose" lastc
+ (f2cl-lib:int-sub lastv k) k (- one) work
+ ldwork v ldv one c ldc)
+ (declare (ignore var-0 var-1 var-3 var-5 var-6 var-8 var-11))
+ (when var-2 (setf lastc var-2)) (when var-4 (setf k var-4))
+ (when var-7 (setf ldwork var-7)) (when var-9 (setf ldv var-9))
+ (when var-10 (setf one var-10))
+ (when var-12 (setf ldc var-12)))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Upper" "Conjugate transpose" "Unit" lastc k one
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ ((+ lastv (f2cl-lib:int-sub k) 1) 1)
+ ((1 ldv) (1 *)) v-%offset%)
+ ldv work ldwork)
+ (declare (ignore var-0 var-1 var-2 var-3 var-7 var-9))
+ (when var-4 (setf lastc var-4)) (when var-5 (setf k var-5))
+ (when var-6 (setf one var-6)) (when var-8 (setf ldv var-8))
+ (when var-10 (setf ldwork var-10)))
+ (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 lastc) nil)
+ (tagbody
+ (setf
+ (f2cl-lib:fref c-%data%
+ (i (f2cl-lib:int-add
+ (f2cl-lib:int-sub lastv k) j))
+ ((1 ldc) (1 *))
+ c-%offset%)
+ (-
+ (f2cl-lib:fref c-%data%
+ (i (f2cl-lib:int-add
+ (f2cl-lib:int-sub lastv k) j))
+ ((1 ldc) (1 *))
+ c-%offset%)
+ (f2cl-lib:fref work-%data% (i j)
+ ((1 ldwork) (1 *)) work-%offset%)))
+ label110))
+ label120)))))))
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame storev "R")
+ (declare (ignore var-1)) (when var-0 (setf storev var-0)) ret-val)
+ (cond
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame direct "F")
+ (declare (ignore var-1)) (when var-0 (setf direct var-0)) ret-val)
+ (cond
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame side "L")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val)
+ (setf lastv
+ (max (the f2cl-lib:integer4 k)
+ (the f2cl-lib:integer4 (ilazlc k m v ldv))))
+ (setf lastc (ilazlc lastv n c ldc))
+ (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)
+ (zcopy lastc
+ (f2cl-lib:array-slice c-%data%
+ f2cl-lib:complex16 (j 1)
+ ((1 ldc) (1 *)) c-%offset%)
+ ldc
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 (1 j)
+ ((1 ldwork) (1 *)) work-%offset%)
+ 1)
+ (declare (ignore var-1 var-3 var-4))
+ (when var-0 (setf lastc var-0))
+ (when var-2 (setf ldc var-2)))
+ (zlacgv lastc
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 (1 j)
+ ((1 ldwork) (1 *)) work-%offset%)
+ 1)
+ 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)
+ (ztrmm "Right" "Upper" "Conjugate transpose" "Unit"
+ lastc k one v ldv
+ work ldwork)
+ (declare (ignore var-0 var-1 var-2 var-3 var-7 var-9))
+ (when var-4 (setf lastc var-4)) (when var-5 (setf k var-5))
+ (when var-6 (setf one var-6)) (when var-8 (setf ldv var-8))
+ (when var-10 (setf ldwork var-10)))
+ (cond
+ ((> lastv 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)
+ (zgemm "Conjugate transpose" "Conjugate transpose" lastc k
+ (f2cl-lib:int-sub lastv k) one
+ (f2cl-lib:array-slice c-%data% f2cl-lib:complex16 ((+ k 1) 1)
+ ((1 ldc) (1 *)) c-%offset%)
+ ldc
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ (1 (f2cl-lib:int-add k 1)) ((1 ldv) (1 *)) v-%offset%)
+ ldv one work ldwork)
+ (declare (ignore var-0 var-1 var-4 var-6 var-8 var-11))
+ (when var-2 (setf lastc var-2)) (when var-3 (setf k var-3))
+ (when var-5 (setf one var-5)) (when var-7 (setf ldc var-7))
+ (when var-9 (setf ldv var-9)) (when var-10 (setf one var-10))
+ (when var-12 (setf ldwork var-12)))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Upper" transt "Non-unit" lastc k one t$ ldt work
+ ldwork)
+ (declare (ignore var-0 var-1 var-3 var-7 var-9))
+ (when var-2 (setf transt var-2)) (when var-4 (setf lastc var-4))
+ (when var-5 (setf k var-5)) (when var-6 (setf one var-6))
+ (when var-8 (setf ldt var-8))
+ (when var-10 (setf ldwork var-10)))
+ (cond
+ ((> lastv 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)
+ (zgemm "Conjugate transpose" "Conjugate transpose"
+ (f2cl-lib:int-sub lastv k) lastc k (- one)
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ (1 (f2cl-lib:int-add k 1)) ((1 ldv) (1 *)) v-%offset%)
+ ldv work ldwork one
+ (f2cl-lib:array-slice c-%data% f2cl-lib:complex16 ((+ k 1) 1)
+ ((1 ldc) (1 *)) c-%offset%)
+ ldc)
+ (declare (ignore var-0 var-1 var-2 var-5 var-6 var-8 var-11))
+ (when var-3 (setf lastc var-3)) (when var-4 (setf k var-4))
+ (when var-7 (setf ldv var-7)) (when var-9 (setf ldwork var-9))
+ (when var-10 (setf one var-10))
+ (when var-12 (setf ldc var-12)))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Upper" "No transpose" "Unit"
+ lastc k one v ldv work
+ ldwork)
+ (declare (ignore var-0 var-1 var-2 var-3 var-7 var-9))
+ (when var-4 (setf lastc var-4)) (when var-5 (setf k var-5))
+ (when var-6 (setf one var-6)) (when var-8 (setf ldv var-8))
+ (when var-10 (setf ldwork var-10)))
+ (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 lastc) nil)
+ (tagbody
+ (setf (f2cl-lib:fref c-%data% (j i)
+ ((1 ldc) (1 *)) c-%offset%)
+ (coerce
+ (- (f2cl-lib:fref c-%data% (j i)
+ ((1 ldc) (1 *)) c-%offset%)
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref work-%data% (i j)
+ ((1 ldwork) (1 *))
+ work-%offset%)))
+ 'f2cl-lib:complex16))
+ label140))
+ label150)))
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame side "R")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val)
+ (setf lastv
+ (max (the f2cl-lib:integer4 k)
+ (the f2cl-lib:integer4 (ilazlc k n v ldv))))
+ (setf lastc (ilazlr m lastv c ldc))
+ (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)
+ (zcopy lastc
+ (f2cl-lib:array-slice c-%data%
+ f2cl-lib:complex16 (1 j)
+ ((1 ldc) (1 *)) c-%offset%)
+ 1
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 (1 j)
+ ((1 ldwork) (1 *)) work-%offset%)
+ 1)
+ (declare (ignore var-1 var-2 var-3 var-4))
+ (when var-0 (setf lastc var-0)))
+ 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)
+ (ztrmm "Right" "Upper" "Conjugate transpose" "Unit"
+ lastc k one v ldv
+ work ldwork)
+ (declare (ignore var-0 var-1 var-2 var-3 var-7 var-9))
+ (when var-4 (setf lastc var-4)) (when var-5 (setf k var-5))
+ (when var-6 (setf one var-6)) (when var-8 (setf ldv var-8))
+ (when var-10 (setf ldwork var-10)))
+ (cond
+ ((> lastv 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)
+ (zgemm "No transpose" "Conjugate transpose" lastc k
+ (f2cl-lib:int-sub lastv k) one
+ (f2cl-lib:array-slice c-%data% f2cl-lib:complex16
+ (1 (f2cl-lib:int-add k 1)) ((1 ldc) (1 *)) c-%offset%)
+ ldc
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ (1 (f2cl-lib:int-add k 1)) ((1 ldv) (1 *)) v-%offset%)
+ ldv one work ldwork)
+ (declare (ignore var-0 var-1 var-4 var-6 var-8 var-11))
+ (when var-2 (setf lastc var-2)) (when var-3 (setf k var-3))
+ (when var-5 (setf one var-5)) (when var-7 (setf ldc var-7))
+ (when var-9 (setf ldv var-9)) (when var-10 (setf one var-10))
+ (when var-12 (setf ldwork var-12)))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Upper" trans "Non-unit"
+ lastc k one t$ ldt work ldwork)
+ (declare (ignore var-0 var-1 var-3 var-7 var-9))
+ (when var-2 (setf trans var-2)) (when var-4 (setf lastc var-4))
+ (when var-5 (setf k var-5)) (when var-6 (setf one var-6))
+ (when var-8 (setf ldt var-8))
+ (when var-10 (setf ldwork var-10)))
+ (cond
+ ((> lastv 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)
+ (zgemm "No transpose" "No transpose"
+ lastc (f2cl-lib:int-sub lastv k)
+ k (- one) work ldwork
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ (1 (f2cl-lib:int-add k 1)) ((1 ldv) (1 *)) v-%offset%)
+ ldv one
+ (f2cl-lib:array-slice c-%data% f2cl-lib:complex16
+ (1 (f2cl-lib:int-add k 1)) ((1 ldc) (1 *)) c-%offset%)
+ ldc)
+ (declare (ignore var-0 var-1 var-3 var-5 var-6 var-8 var-11))
+ (when var-2 (setf lastc var-2)) (when var-4 (setf k var-4))
+ (when var-7 (setf ldwork var-7)) (when var-9 (setf ldv var-9))
+ (when var-10 (setf one var-10))
+ (when var-12 (setf ldc var-12)))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Upper" "No transpose" "Unit"
+ lastc k one v ldv work
+ ldwork)
+ (declare (ignore var-0 var-1 var-2 var-3 var-7 var-9))
+ (when var-4 (setf lastc var-4)) (when var-5 (setf k var-5))
+ (when var-6 (setf one var-6)) (when var-8 (setf ldv var-8))
+ (when var-10 (setf ldwork var-10)))
+ (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 lastc) 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%)))
+ label170))
+ label180)))))
+ (t
+ (cond
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame side "L")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val)
+ (setf lastv
+ (max (the f2cl-lib:integer4 k)
+ (the f2cl-lib:integer4 (ilazlc k m v ldv))))
+ (setf lastc (ilazlc lastv n c ldc))
+ (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)
+ (zcopy lastc
+ (f2cl-lib:array-slice c-%data%
+ f2cl-lib:complex16
+ ((+ lastv (f2cl-lib:int-sub k) j) 1)
+ ((1 ldc) (1 *)) c-%offset%)
+ ldc
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 (1 j)
+ ((1 ldwork) (1 *)) work-%offset%)
+ 1)
+ (declare (ignore var-1 var-3 var-4))
+ (when var-0 (setf lastc var-0))
+ (when var-2 (setf ldc var-2)))
+ (zlacgv lastc
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 (1 j)
+ ((1 ldwork) (1 *)) work-%offset%)
+ 1)
+ label190))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Lower" "Conjugate transpose" "Unit" lastc k one
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ (1 (f2cl-lib:int-add (f2cl-lib:int-sub lastv k) 1))
+ ((1 ldv) (1 *))
+ v-%offset%)
+ ldv work ldwork)
+ (declare (ignore var-0 var-1 var-2 var-3 var-7 var-9))
+ (when var-4 (setf lastc var-4)) (when var-5 (setf k var-5))
+ (when var-6 (setf one var-6)) (when var-8 (setf ldv var-8))
+ (when var-10 (setf ldwork var-10)))
+ (cond
+ ((> lastv 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)
+ (zgemm "Conjugate transpose" "Conjugate transpose" lastc k
+ (f2cl-lib:int-sub lastv k) one c ldc v ldv one work ldwork)
+ (declare (ignore var-0 var-1 var-4 var-6 var-8 var-11))
+ (when var-2 (setf lastc var-2)) (when var-3 (setf k var-3))
+ (when var-5 (setf one var-5)) (when var-7 (setf ldc var-7))
+ (when var-9 (setf ldv var-9)) (when var-10 (setf one var-10))
+ (when var-12 (setf ldwork var-12)))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
+ var-9 var-10)
+ (ztrmm "Right" "Lower" transt "Non-unit" lastc k one t$ ldt work
+ ldwork)
+ (declare (ignore var-0 var-1 var-3 var-7 var-9))
+ (when var-2 (setf transt var-2)) (when var-4 (setf lastc var-4))
+ (when var-5 (setf k var-5)) (when var-6 (setf one var-6))
+ (when var-8 (setf ldt var-8))
+ (when var-10 (setf ldwork var-10)))
+ (cond
+ ((> lastv 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)
+ (zgemm "Conjugate transpose" "Conjugate transpose"
+ (f2cl-lib:int-sub lastv k) lastc k (- one)
+ v ldv work ldwork one c
+ ldc)
+ (declare (ignore var-0 var-1 var-2 var-5 var-6 var-8 var-11))
+ (when var-3 (setf lastc var-3)) (when var-4 (setf k var-4))
+ (when var-7 (setf ldv var-7)) (when var-9 (setf ldwork var-9))
+ (when var-10 (setf one var-10))
+ (when var-12 (setf ldc var-12)))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8
+ var-9 var-10)
+ (ztrmm "Right" "Lower" "No transpose" "Unit" lastc k one
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ (1 (f2cl-lib:int-add (f2cl-lib:int-sub lastv k) 1))
+ ((1 ldv) (1 *))
+ v-%offset%)
+ ldv work ldwork)
+ (declare (ignore var-0 var-1 var-2 var-3 var-7 var-9))
+ (when var-4 (setf lastc var-4)) (when var-5 (setf k var-5))
+ (when var-6 (setf one var-6)) (when var-8 (setf ldv var-8))
+ (when var-10 (setf ldwork var-10)))
+ (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 lastc) nil)
+ (tagbody
+ (setf
+ (f2cl-lib:fref c-%data%
+ ((f2cl-lib:int-add
+ (f2cl-lib:int-sub lastv k) j) i)
+ ((1 ldc) (1 *))
+ c-%offset%)
+ (coerce
+ (-
+ (f2cl-lib:fref c-%data%
+ ((f2cl-lib:int-add
+ (f2cl-lib:int-sub lastv k) j) i)
+ ((1 ldc) (1 *)) c-%offset%)
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref work-%data% (i j)
+ ((1 ldwork) (1 *))
+ work-%offset%)))
+ 'f2cl-lib:complex16))
+ label200))
+ label210)))
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame side "R")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val)
+ (setf lastv
+ (max (the f2cl-lib:integer4 k)
+ (the f2cl-lib:integer4 (ilazlc k n v ldv))))
+ (setf lastc (ilazlr m lastv c ldc))
+ (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)
+ (zcopy lastc
+ (f2cl-lib:array-slice c-%data%
+ f2cl-lib:complex16
+ (1 (f2cl-lib:int-add
+ (f2cl-lib:int-sub lastv k) j))
+ ((1 ldc) (1 *))
+ c-%offset%)
+ 1
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 (1 j)
+ ((1 ldwork) (1 *)) work-%offset%)
+ 1)
+ (declare (ignore var-1 var-2 var-3 var-4))
+ (when var-0 (setf lastc var-0)))
+ label220))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Lower" "Conjugate transpose" "Unit" lastc k one
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ (1 (f2cl-lib:int-add (f2cl-lib:int-sub lastv k) 1))
+ ((1 ldv) (1 *))
+ v-%offset%)
+ ldv work ldwork)
+ (declare (ignore var-0 var-1 var-2 var-3 var-7 var-9))
+ (when var-4 (setf lastc var-4)) (when var-5 (setf k var-5))
+ (when var-6 (setf one var-6)) (when var-8 (setf ldv var-8))
+ (when var-10 (setf ldwork var-10)))
+ (cond
+ ((> lastv 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)
+ (zgemm "No transpose" "Conjugate transpose" lastc k
+ (f2cl-lib:int-sub lastv k) one c ldc v ldv one work ldwork)
+ (declare (ignore var-0 var-1 var-4 var-6 var-8 var-11))
+ (when var-2 (setf lastc var-2)) (when var-3 (setf k var-3))
+ (when var-5 (setf one var-5)) (when var-7 (setf ldc var-7))
+ (when var-9 (setf ldv var-9)) (when var-10 (setf one var-10))
+ (when var-12 (setf ldwork var-12)))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Lower" trans "Non-unit"
+ lastc k one t$ ldt work ldwork)
+ (declare (ignore var-0 var-1 var-3 var-7 var-9))
+ (when var-2 (setf trans var-2)) (when var-4 (setf lastc var-4))
+ (when var-5 (setf k var-5)) (when var-6 (setf one var-6))
+ (when var-8 (setf ldt var-8))
+ (when var-10 (setf ldwork var-10)))
+ (cond
+ ((> lastv 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)
+ (zgemm "No transpose" "No transpose" lastc
+ (f2cl-lib:int-sub lastv k)
+ k (- one) work ldwork v ldv one c ldc)
+ (declare (ignore var-0 var-1 var-3 var-5 var-6 var-8 var-11))
+ (when var-2 (setf lastc var-2)) (when var-4 (setf k var-4))
+ (when var-7 (setf ldwork var-7)) (when var-9 (setf ldv var-9))
+ (when var-10 (setf one var-10))
+ (when var-12 (setf ldc var-12)))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
+ var-8 var-9 var-10)
+ (ztrmm "Right" "Lower" "No transpose" "Unit" lastc k one
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ (1 (f2cl-lib:int-add (f2cl-lib:int-sub lastv k) 1))
+ ((1 ldv) (1 *))
+ v-%offset%)
+ ldv work ldwork)
+ (declare (ignore var-0 var-1 var-2 var-3 var-7 var-9))
+ (when var-4 (setf lastc var-4)) (when var-5 (setf k var-5))
+ (when var-6 (setf one var-6)) (when var-8 (setf ldv var-8))
+ (when var-10 (setf ldwork var-10)))
+ (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 lastc) nil)
+ (tagbody
+ (setf
+ (f2cl-lib:fref c-%data%
+ (i (f2cl-lib:int-add (f2cl-lib:int-sub
+ lastv k) j)) ((1 ldc) (1 *))
+ c-%offset%)
+ (-
+ (f2cl-lib:fref c-%data%
+ (i (f2cl-lib:int-add
+ (f2cl-lib:int-sub lastv k) j))
+ ((1 ldc) (1 *))
+ c-%offset%)
+ (f2cl-lib:fref work-%data% (i j)
+ ((1 ldwork) (1 *)) work-%offset%)))
+ label230))
+ label240))))))))
+ (go end_label) end_label
+ (return
+ (values side trans direct storev nil nil k nil ldv nil ldt nil ldc nil
+ ldwork))))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -115715,7 +126380,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlarf.f}
* =====================================================================
SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
@@ -115822,10 +126487,90 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlarf}
-
+(let*
+ ((one (coerce (f2cl-lib:cmplx 1.0d0 0.0d0) 'f2cl-lib:complex16))
+ (zero (coerce (f2cl-lib:cmplx 0.0d0 0.0d0) 'f2cl-lib:complex16)))
+ (declare (type (f2cl-lib:complex16) one) (type (f2cl-lib:complex16) zero)
+ (ignorable one zero))
+ (defun zlarf (side m n v incv tau c ldc work)
+ (declare (type (simple-array character (*)) side)
+ (type (f2cl-lib:integer4) ldc incv n m)
+ (type (array f2cl-lib:complex16 (*)) work c v)
+ (type (f2cl-lib:complex16) tau))
+ (f2cl-lib:with-multi-array-data
+ ((v f2cl-lib:complex16 v-%data% v-%offset%)
+ (c f2cl-lib:complex16 c-%data% c-%offset%)
+ (work f2cl-lib:complex16 work-%data% work-%offset%)
+ (side character side-%data% side-%offset%))
+ (prog
+ ((i 0) (lastv 0) (lastc 0) (applyleft nil))
+ (declare (type (f2cl-lib:integer4) lastc lastv i)
+ (type f2cl-lib:logical applyleft))
+ (setf applyleft
+ (multiple-value-bind (ret-val var-0 var-1) (lsame side "L")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val))
+ (setf lastv 0) (setf lastc 0)
+ (cond
+ ((/= tau zero)
+ (tagbody (cond (applyleft (setf lastv m)) (t (setf lastv n)))
+ (cond
+ ((> incv 0)
+ (setf i
+ (f2cl-lib:int-add 1
+ (f2cl-lib:int-mul (f2cl-lib:int-sub lastv 1) incv))))
+ (t (setf i 1)))
+ label100000
+ (if
+ (not
+ (and (> lastv 0)
+ (= (f2cl-lib:fref v-%data% (i) ((1 *)) v-%offset%) zero)))
+ (go label100001))
+ (setf lastv (f2cl-lib:int-sub lastv 1))
+ (setf i (f2cl-lib:int-sub i incv))
+ (go label100000) label100001
+ (cond (applyleft (setf lastc (ilazlc lastv n c ldc)))
+ (t (setf lastc (ilazlr m lastv c ldc)))))))
+ (cond
+ (applyleft
+ (cond
+ ((> lastv 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)
+ (zgemv "Conjugate transpose" lastv lastc one c
+ ldc v incv zero work 1)
+ (declare (ignore var-0 var-4 var-6 var-9 var-10))
+ (when var-1 (setf lastv var-1)) (when var-2 (setf lastc var-2))
+ (when var-3 (setf one var-3)) (when var-5 (setf ldc var-5))
+ (when var-7 (setf incv var-7)) (when var-8 (setf zero var-8)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
+ (zgerc lastv lastc (- tau) v incv work 1 c ldc)
+ (declare (ignore var-2 var-3 var-5 var-6 var-7))
+ (when var-0 (setf lastv var-0)) (when var-1 (setf lastc var-1))
+ (when var-4 (setf incv var-4)) (when var-8 (setf ldc var-8))))))
+ (t
+ (cond
+ ((> lastv 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)
+ (zgemv "No transpose" lastc lastv one c ldc v incv zero work 1)
+ (declare (ignore var-0 var-4 var-6 var-9 var-10))
+ (when var-1 (setf lastc var-1)) (when var-2 (setf lastv var-2))
+ (when var-3 (setf one var-3)) (when var-5 (setf ldc var-5))
+ (when var-7 (setf incv var-7)) (when var-8 (setf zero var-8)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
+ (zgerc lastc lastv (- tau) work 1 v incv c ldc)
+ (declare (ignore var-2 var-3 var-4 var-5 var-7))
+ (when var-0 (setf lastc var-0)) (when var-1 (setf lastv var-1))
+ (when var-6 (setf incv var-6)) (when var-8 (setf ldc var-8)))))))
+ (go end_label) end_label
+ (return (values side nil nil nil incv nil nil ldc nil))))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -115937,7 +126682,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlzrfg.f}
* =====================================================================
SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
*
@@ -116037,10 +126782,68 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlarfg}
-
+(let* ((one 1.0d0) (zero 0.0d0))
+ (declare (type (double-float 1.0d0 1.0d0) one)
+ (type (double-float 0.0d0 0.0d0) zero) (ignorable one zero))
+ (defun zlarfg (n alpha x incx tau)
+ (declare (type (f2cl-lib:integer4) incx n)
+ (type (f2cl-lib:complex16) tau alpha)
+ (type (array f2cl-lib:complex16 (*)) x))
+ (f2cl-lib:with-multi-array-data
+ ((x f2cl-lib:complex16 x-%data% x-%offset%))
+ (prog
+ ((alphi 0.0d0) (alphr 0.0d0) (beta 0.0d0) (rsafmn 0.0d0) (safmin 0.0d0)
+ (xnorm 0.0d0) (j 0) (knt 0))
+ (declare (type (double-float) xnorm safmin rsafmn beta alphr alphi)
+ (type (f2cl-lib:integer4) knt j))
+ (cond ((<= n 0) (setf tau (coerce zero 'f2cl-lib:complex16))
+ (go end_label)))
+ (setf xnorm
+ (multiple-value-bind (ret-val var-0 var-1 var-2)
+ (dznrm2 (f2cl-lib:int-sub n 1) x incx) (declare (ignore var-0 var-1))
+ (when var-2 (setf incx var-2)) ret-val))
+ (setf alphr (f2cl-lib:dble alpha)) (setf alphi (f2cl-lib:dimag alpha))
+ (cond
+ ((and (= xnorm zero) (= alphi zero))
+ (setf tau (coerce zero 'f2cl-lib:complex16)))
+ (t (setf beta (- (f2cl-lib:sign (dlapy3 alphr alphi xnorm) alphr)))
+ (setf safmin (/ (dlamch "S") (dlamch "E")))
+ (setf rsafmn (/ one safmin))
+ (setf knt 0)
+ (cond
+ ((< (abs beta) safmin)
+ (tagbody label10 (setf knt (f2cl-lib:int-add knt 1))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zdscal (f2cl-lib:int-sub n 1) rsafmn x incx)
+ (declare (ignore var-0 var-2)) (when var-1 (setf rsafmn var-1))
+ (when var-3 (setf incx var-3)))
+ (setf beta (* beta rsafmn)) (setf alphi (* alphi rsafmn))
+ (setf alphr (* alphr rsafmn))
+ (if (< (abs beta) safmin) (go label10))
+ (setf xnorm
+ (multiple-value-bind (ret-val var-0 var-1 var-2)
+ (dznrm2 (f2cl-lib:int-sub n 1) x incx)
+ (declare (ignore var-0 var-1))
+ (when var-2 (setf incx var-2)) ret-val))
+ (setf alpha (f2cl-lib:dcmplx alphr alphi))
+ (setf beta
+ (- (f2cl-lib:sign (dlapy3 alphr alphi xnorm) alphr))))))
+ (setf tau
+ (f2cl-lib:dcmplx (/ (- beta alphr) beta) (/ (- alphi) beta)))
+ (setf alpha (zladiv (f2cl-lib:dcmplx one) (- alpha beta)))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zscal (f2cl-lib:int-sub n 1) alpha x incx)
+ (declare (ignore var-0 var-2))
+ (when var-1 (setf alpha var-1)) (when var-3 (setf incx var-3)))
+ (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
+ ((> j knt) nil)
+ (tagbody
+ (setf beta (* beta safmin)) label20))
+ (setf alpha (coerce beta 'f2cl-lib:complex16))))
+ (go end_label) end_label (return (values nil alpha nil incx tau))))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -116203,7 +127006,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlarft.f}
* =====================================================================
SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
@@ -116376,10 +127179,354 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlarft}
-
+(let*
+ ((one (coerce (f2cl-lib:cmplx 1.0d0 0.0d0) 'f2cl-lib:complex16))
+ (zero (coerce (f2cl-lib:cmplx 0.0d0 0.0d0) 'f2cl-lib:complex16)))
+ (declare (type (f2cl-lib:complex16) one) (type (f2cl-lib:complex16) zero)
+ (ignorable one zero))
+ (defun zlarft (direct storev n k v ldv tau t$ ldt)
+ (declare (type (simple-array character (*)) storev direct)
+ (type (f2cl-lib:integer4) ldt ldv k n)
+ (type (array f2cl-lib:complex16 (*)) t$ tau v))
+ (f2cl-lib:with-multi-array-data
+ ((v f2cl-lib:complex16 v-%data% v-%offset%)
+ (tau f2cl-lib:complex16 tau-%data% tau-%offset%)
+ (t$ f2cl-lib:complex16 t$-%data% t$-%offset%)
+ (direct character direct-%data% direct-%offset%)
+ (storev character storev-%data% storev-%offset%))
+ (prog
+ ((vii #C(0.0d0 0.0d0)) (i 0) (j 0) (prevlastv 0) (lastv 0))
+ (declare (type (f2cl-lib:complex16) vii)
+ (type (f2cl-lib:integer4) lastv prevlastv j i))
+ (if (= n 0) (go end_label))
+ (cond
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame direct "F")
+ (declare (ignore var-1)) (when var-0 (setf direct var-0)) ret-val)
+ (setf prevlastv n)
+ (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
+ ((> i k) nil)
+ (tagbody
+ (setf prevlastv
+ (max (the f2cl-lib:integer4 prevlastv)
+ (the f2cl-lib:integer4 i)))
+ (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)
+ label10)))
+ (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
+ ((multiple-value-bind (ret-val var-0 var-1)
+ (lsame storev "C")
+ (declare (ignore var-1))
+ (when var-0 (setf storev var-0)) ret-val)
+ (f2cl-lib:fdo (lastv n (f2cl-lib:int-add lastv
+ (f2cl-lib:int-sub 1)))
+ ((>
+ lastv (f2cl-lib:int-add i 1))
+ nil)
+ (tagbody
+ (if
+ (/= (f2cl-lib:fref v-%data% (lastv i)
+ ((1 ldv) (1 *)) v-%offset%)
+ zero)
+ (go f2cl-lib::exit))
+ label100000))
+ (setf j
+ (min (the f2cl-lib:integer4 lastv)
+ (the f2cl-lib:integer4 prevlastv)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5
+ var-6 var-7 var-8 var-9 var-10)
+ (zgemv "Conjugate transpose"
+ (f2cl-lib:int-add (f2cl-lib:int-sub j i) 1)
+ (f2cl-lib:int-sub i 1)
+ (- (f2cl-lib:fref tau-%data% (i) ((1 *))
+ tau-%offset%))
+ (f2cl-lib:array-slice v-%data%
+ f2cl-lib:complex16 (i 1)
+ ((1 ldv) (1 *)) v-%offset%)
+ ldv
+ (f2cl-lib:array-slice v-%data%
+ f2cl-lib:complex16 (i i)
+ ((1 ldv) (1 *)) v-%offset%)
+ 1 zero
+ (f2cl-lib:array-slice t$-%data%
+ f2cl-lib:complex16 (1 i)
+ ((1 ldt) (1 *)) t$-%offset%)
+ 1)
+ (declare
+ (ignore var-0 var-1 var-2 var-3 var-4
+ var-6 var-7 var-9 var-10))
+ (when var-5 (setf ldv var-5))
+ (when var-8 (setf zero var-8))))
+ (t
+ (f2cl-lib:fdo (lastv n (f2cl-lib:int-add lastv
+ (f2cl-lib:int-sub 1)))
+ ((>
+ lastv (f2cl-lib:int-add i 1))
+ nil)
+ (tagbody
+ (if
+ (/= (f2cl-lib:fref v-%data% (i lastv)
+ ((1 ldv) (1 *)) v-%offset%)
+ zero)
+ (go f2cl-lib::exit))
+ label100001))
+ (setf j
+ (min (the f2cl-lib:integer4 lastv)
+ (the f2cl-lib:integer4 prevlastv)))
+ (if (< i j)
+ (zlacgv (f2cl-lib:int-sub j i)
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ (i (f2cl-lib:int-add i 1))
+ ((1 ldv) (1 *)) v-%offset%)
+ ldv))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4
+ var-5 var-6 var-7 var-8 var-9 var-10)
+ (zgemv "No transpose" (f2cl-lib:int-sub i 1)
+ (f2cl-lib:int-add (f2cl-lib:int-sub j i) 1)
+ (- (f2cl-lib:fref tau-%data% (i) ((1 *))
+ tau-%offset%))
+ (f2cl-lib:array-slice v-%data%
+ f2cl-lib:complex16 (1 i)
+ ((1 ldv) (1 *)) v-%offset%)
+ ldv
+ (f2cl-lib:array-slice v-%data%
+ f2cl-lib:complex16 (i i)
+ ((1 ldv) (1 *)) v-%offset%)
+ ldv zero
+ (f2cl-lib:array-slice t$-%data%
+ f2cl-lib:complex16 (1 i)
+ ((1 ldt) (1 *)) t$-%offset%)
+ 1)
+ (declare (ignore var-0 var-1 var-2 var-3
+ var-4 var-6 var-9 var-10))
+ (when var-5 (setf ldv var-5))
+ (when var-7 (setf ldv var-7))
+ (when var-8 (setf zero var-8)))
+ (if (< i j)
+ (zlacgv (f2cl-lib:int-sub j i)
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ (i (f2cl-lib:int-add i 1))
+ ((1 ldv) (1 *)) v-%offset%)
+ ldv))))
+ (setf (f2cl-lib:fref v-%data% (i i)
+ ((1 ldv) (1 *)) v-%offset%) vii)
+ (multiple-value-bind (var-0 var-1 var-2 var-3
+ var-4 var-5 var-6 var-7)
+ (ztrmv "Upper" "No transpose" "Non-unit"
+ (f2cl-lib:int-sub i 1) t$ ldt
+ (f2cl-lib:array-slice t$-%data%
+ f2cl-lib:complex16 (1 i)
+ ((1 ldt) (1 *)) t$-%offset%)
+ 1)
+ (declare (ignore var-0 var-1 var-2 var-3
+ var-4 var-6 var-7))
+ (when var-5 (setf ldt var-5)))
+ (setf (f2cl-lib:fref t$-%data% (i i)
+ ((1 ldt) (1 *)) t$-%offset%)
+ (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%))
+ (cond
+ ((> i 1)
+ (setf prevlastv
+ (max (the f2cl-lib:integer4 prevlastv)
+ (the f2cl-lib:integer4 lastv))))
+ (t (setf prevlastv lastv)))))
+ label20)))
+ (t (setf prevlastv 1)
+ (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)
+ label30)))
+ (t
+ (cond
+ ((< i k)
+ (cond
+ ((multiple-value-bind (ret-val var-0 var-1)
+ (lsame storev "C")
+ (declare (ignore var-1))
+ (when var-0 (setf storev var-0)) ret-val)
+ (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)
+ (f2cl-lib:fdo (lastv 1 (f2cl-lib:int-add lastv 1))
+ ((> lastv
+ (f2cl-lib:int-add i (f2cl-lib:int-sub 1)))
+ nil)
+ (tagbody
+ (if
+ (/= (f2cl-lib:fref v-%data% (lastv i)
+ ((1 ldv) (1 *)) v-%offset%)
+ zero)
+ (go f2cl-lib::exit))
+ label100002))
+ (setf j
+ (max (the f2cl-lib:integer4 lastv)
+ (the f2cl-lib:integer4 prevlastv)))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5
+ var-6 var-7 var-8 var-9 var-10)
+ (zgemv "Conjugate transpose"
+ (f2cl-lib:int-add
+ (f2cl-lib:int-sub (f2cl-lib:int-add
+ (f2cl-lib:int-sub n k) i) j)
+ 1)
+ (f2cl-lib:int-sub k i)
+ (- (f2cl-lib:fref tau-%data% (i)
+ ((1 *)) tau-%offset%))
+ (f2cl-lib:array-slice v-%data% f2cl-lib:complex16
+ (j (f2cl-lib:int-add i 1))
+ ((1 ldv) (1 *)) v-%offset%)
+ ldv
+ (f2cl-lib:array-slice v-%data%
+ f2cl-lib:complex16 (j i)
+ ((1 ldv) (1 *)) v-%offset%)
+ 1 zero
+ (f2cl-lib:array-slice t$-%data%
+ f2cl-lib:complex16 ((+ i 1) i)
+ ((1 ldt) (1 *)) t$-%offset%)
+ 1)
+ (declare
+ (ignore var-0 var-1 var-2 var-3 var-4
+ var-6 var-7 var-9 var-10))
+ (when var-5 (setf ldv var-5))
+ (when var-8 (setf zero var-8)))
+ (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)
+ (f2cl-lib:fdo (lastv 1 (f2cl-lib:int-add lastv 1))
+ ((> lastv
+ (f2cl-lib:int-add i (f2cl-lib:int-sub 1)))
+ nil)
+ (tagbody
+ (if
+ (/= (f2cl-lib:fref v-%data% (i lastv)
+ ((1 ldv) (1 *)) v-%offset%)
+ zero)
+ (go f2cl-lib::exit))
+ label100003))
+ (setf j
+ (max (the f2cl-lib:integer4 lastv)
+ (the f2cl-lib:integer4 prevlastv)))
+ (zlacgv
+ (f2cl-lib:int-add
+ (f2cl-lib:int-sub (f2cl-lib:int-add
+ (f2cl-lib:int-sub n k) i) 1 j)
+ 1)
+ (f2cl-lib:array-slice v-%data%
+ f2cl-lib:complex16 (i j)
+ ((1 ldv) (1 *)) v-%offset%)
+ ldv)
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6
+ var-7 var-8 var-9 var-10)
+ (zgemv "No transpose" (f2cl-lib:int-sub k i)
+ (f2cl-lib:int-add
+ (f2cl-lib:int-sub (f2cl-lib:int-add
+ (f2cl-lib:int-sub n k) i) j)
+ 1)
+ (- (f2cl-lib:fref tau-%data% (i)
+ ((1 *)) tau-%offset%))
+ (f2cl-lib:array-slice v-%data%
+ f2cl-lib:complex16 ((+ i 1) j)
+ ((1 ldv) (1 *)) v-%offset%)
+ ldv
+ (f2cl-lib:array-slice v-%data%
+ f2cl-lib:complex16 (i j)
+ ((1 ldv) (1 *)) v-%offset%)
+ ldv zero
+ (f2cl-lib:array-slice t$-%data%
+ f2cl-lib:complex16 ((+ i 1) i)
+ ((1 ldt) (1 *)) t$-%offset%)
+ 1)
+ (declare (ignore var-0 var-1 var-2 var-3
+ var-4 var-6 var-9 var-10))
+ (when var-5 (setf ldv var-5))
+ (when var-7 (setf ldv var-7))
+ (when var-8 (setf zero var-8)))
+ (zlacgv
+ (f2cl-lib:int-add
+ (f2cl-lib:int-sub
+ (f2cl-lib:int-add (f2cl-lib:int-sub n k) i) 1 j)
+ 1)
+ (f2cl-lib:array-slice v-%data%
+ f2cl-lib:complex16 (i j)
+ ((1 ldv) (1 *)) v-%offset%)
+ ldv)
+ (setf
+ (f2cl-lib:fref v-%data%
+ (i (f2cl-lib:int-add
+ (f2cl-lib:int-sub n k) i)) ((1 ldv) (1 *))
+ v-%offset%)
+ vii)))
+ (multiple-value-bind (var-0 var-1 var-2 var-3
+ var-4 var-5 var-6 var-7)
+ (ztrmv "Lower" "No transpose" "Non-unit"
+ (f2cl-lib:int-sub k i)
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16
+ ((+ i 1) (f2cl-lib:int-add i 1))
+ ((1 ldt) (1 *)) t$-%offset%)
+ ldt
+ (f2cl-lib:array-slice t$-%data%
+ f2cl-lib:complex16 ((+ i 1) i)
+ ((1 ldt) (1 *)) t$-%offset%)
+ 1)
+ (declare (ignore var-0 var-1 var-2 var-3
+ var-4 var-6 var-7))
+ (when var-5 (setf ldt var-5)))
+ (cond
+ ((> i 1)
+ (setf prevlastv
+ (min (the f2cl-lib:integer4 prevlastv)
+ (the f2cl-lib:integer4 lastv))))
+ (t (setf prevlastv lastv)))))
+ (setf (f2cl-lib:fref t$-%data% (i i)
+ ((1 ldt) (1 *)) t$-%offset%)
+ (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%))))
+ label40))))
+ (go end_label) end_label
+ (return (values direct storev nil nil nil ldv nil nil ldt))))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -116485,7 +127632,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlartg.f}
* =====================================================================
SUBROUTINE ZLARTG( F, G, CS, SN, R )
*
@@ -116643,10 +127790,107 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlartg}
-
+(let*
+ ((two 2.0d0) (one 1.0d0) (zero 0.0d0)
+ (czero (coerce (f2cl-lib:cmplx 0.0d0 0.0d0) 'f2cl-lib:complex16)))
+ (declare (type (double-float 2.0d0 2.0d0) two)
+ (type (double-float 1.0d0 1.0d0) one) (type (double-float 0.0d0 0.0d0) zero)
+ (type (f2cl-lib:complex16) czero) (ignorable two one zero czero))
+ (defun zlartg (f g cs sn r)
+ (declare (type (f2cl-lib:complex16) r sn g f) (type (double-float) cs))
+ (labels
+ ((abs1 (ff) (max (abs (f2cl-lib:dble ff)) (abs (f2cl-lib:dimag ff))))
+ (abssq (ff) (+ (expt (f2cl-lib:dble ff) 2) (expt (f2cl-lib:dimag ff) 2))))
+ (declare
+ (ftype (function (f2cl-lib:complex16) (values double-float &rest t)) abs1))
+ (declare
+ (ftype (function (f2cl-lib:complex16) (values double-float &rest t))
+ abssq))
+ (prog
+ ((ff #C(0.0d0 0.0d0)) (fs #C(0.0d0 0.0d0)) (gs #C(0.0d0 0.0d0)) (d 0.0d0)
+ (di 0.0d0) (dr 0.0d0) (eps 0.0d0) (f2 0.0d0) (f2s 0.0d0) (g2 0.0d0)
+ (g2s 0.0d0) (safmin 0.0d0) (safmn2 0.0d0) (safmx2 0.0d0) (scale 0.0d0)
+ (i 0) (count$ 0))
+ (declare (type (f2cl-lib:complex16) gs fs ff)
+ (type (double-float) scale safmx2 safmn2 safmin g2s g2 f2s f2 eps dr di d)
+ (type (f2cl-lib:integer4) count$ i))
+ (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)) (setf scale (max (abs1 f) (abs1 g)))
+ (setf fs f) (setf gs g) (setf count$ 0)
+ (cond
+ ((>= scale safmx2)
+ (tagbody label10 (setf count$ (f2cl-lib:int-add count$ 1))
+ (setf fs (* fs safmn2)) (setf gs (* gs safmn2))
+ (setf scale (* scale safmn2)) (if (>= scale safmx2) (go label10))))
+ ((<= scale safmn2)
+ (tagbody
+ (cond
+ ((= g czero) (setf cs one) (setf sn czero) (setf r f) (go end_label)))
+ label20 (setf count$ (f2cl-lib:int-sub count$ 1))
+ (setf fs (* fs safmx2)) (setf gs (* gs safmx2))
+ (setf scale (* scale safmx2)) (if (<= scale safmn2) (go label20)))))
+ (setf f2 (abssq fs)) (setf g2 (abssq gs))
+ (cond
+ ((<= f2 (* (max g2 one) safmin))
+ (cond
+ ((= f czero) (setf cs zero)
+ (setf r
+ (coerce (dlapy2 (f2cl-lib:dble g) (f2cl-lib:dimag g))
+ 'f2cl-lib:complex16))
+ (setf d (dlapy2 (f2cl-lib:dble gs) (f2cl-lib:dimag gs)))
+ (setf sn
+ (f2cl-lib:dcmplx (/ (f2cl-lib:dble gs) d)
+ (/ (- (f2cl-lib:dimag gs)) d)))
+ (go end_label)))
+ (setf f2s (dlapy2 (f2cl-lib:dble fs) (f2cl-lib:dimag fs)))
+ (setf g2s (f2cl-lib:fsqrt g2)) (setf cs (/ f2s g2s))
+ (cond
+ ((> (abs1 f) one) (setf d (dlapy2 (f2cl-lib:dble f) (f2cl-lib:dimag f)))
+ (setf ff
+ (f2cl-lib:dcmplx (/ (f2cl-lib:dble f) d) (/ (f2cl-lib:dimag f) d))))
+ (t (setf dr (* safmx2 (f2cl-lib:dble f)))
+ (setf di (* safmx2 (f2cl-lib:dimag f)))
+ (setf d
+ (multiple-value-bind (ret-val var-0 var-1) (dlapy2 dr di)
+ (declare (ignore)) (when var-0 (setf dr var-0))
+ (when var-1 (setf di var-1)) ret-val))
+ (setf ff (f2cl-lib:dcmplx (/ dr d) (/ di d)))))
+ (setf sn
+ (* ff
+ (f2cl-lib:dcmplx (/ (f2cl-lib:dble gs) g2s)
+ (/ (- (f2cl-lib:dimag gs)) g2s))))
+ (setf r (+ (* cs f) (* sn g))))
+ (t (setf f2s (f2cl-lib:fsqrt (+ one (/ g2 f2))))
+ (setf r
+ (f2cl-lib:dcmplx (* f2s (f2cl-lib:dble fs))
+ (* f2s (f2cl-lib:dimag fs))))
+ (setf cs (/ one f2s)) (setf d (+ f2 g2))
+ (setf sn
+ (f2cl-lib:dcmplx (/ (f2cl-lib:dble r) d) (/ (f2cl-lib:dimag r) d)))
+ (setf sn (coerce (* sn (f2cl-lib:dconjg gs)) 'f2cl-lib:complex16))
+ (cond
+ ((/= count$ 0)
+ (cond
+ ((> count$ 0)
+ (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
+ ((> i count$) nil)
+ (tagbody
+ (setf r (* r safmx2)) label30)))
+ (t
+ (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
+ ((> i
+ (f2cl-lib:int-sub count$))
+ nil)
+ (tagbody (setf r (* r safmn2)) label40))))))))
+ (go end_label) end_label (return (values nil nil cs sn r))))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -116785,7 +128029,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlascl.f}
* =====================================================================
SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
*
@@ -117013,10 +128257,231 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlascl}
-
+(let* ((zero 0.0d0) (one 1.0d0))
+ (declare (type (double-float 0.0d0 0.0d0) zero)
+ (type (double-float 1.0d0 1.0d0) one) (ignorable zero one))
+ (defun zlascl (type kl ku cfrom cto m n a lda info)
+ (declare (type (simple-array character (*)) type)
+ (type (f2cl-lib:integer4) info lda n m ku kl)
+ (type (double-float) cto cfrom) (type (array f2cl-lib:complex16 (*)) a))
+ (f2cl-lib:with-multi-array-data
+ ((a f2cl-lib:complex16 a-%data% a-%offset%)
+ (type character type-%data% type-%offset%))
+ (prog
+ ((bignum 0.0d0) (cfrom1 0.0d0) (cfromc 0.0d0) (cto1 0.0d0) (ctoc 0.0d0)
+ (mul 0.0d0) (smlnum 0.0d0) (i 0) (itype 0) (j 0) (k1 0)
+ (k2 0) (k3 0) (k4 0)
+ (done nil))
+ (declare (type (double-float) smlnum mul ctoc cto1
+ cfromc cfrom1 bignum)
+ (type (f2cl-lib:integer4) k4 k3 k2 k1 j itype i)
+ (type f2cl-lib:logical done))
+ (setf info 0)
+ (cond
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame type "G")
+ (declare (ignore var-1)) (when var-0 (setf type var-0)) ret-val)
+ (setf itype 0))
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame type "L")
+ (declare (ignore var-1)) (when var-0 (setf type var-0)) ret-val)
+ (setf itype 1))
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame type "U")
+ (declare (ignore var-1)) (when var-0 (setf type var-0)) ret-val)
+ (setf itype 2))
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame type "H")
+ (declare (ignore var-1)) (when var-0 (setf type var-0)) ret-val)
+ (setf itype 3))
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame type "B")
+ (declare (ignore var-1)) (when var-0 (setf type var-0)) ret-val)
+ (setf itype 4))
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame type "Q")
+ (declare (ignore var-1)) (when var-0 (setf type var-0)) ret-val)
+ (setf itype 5))
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame type "Z")
+ (declare (ignore var-1)) (when var-0 (setf type var-0)) ret-val)
+ (setf itype 6))
+ (t (setf itype -1)))
+ (cond ((= itype (f2cl-lib:int-sub 1)) (setf info -1))
+ ((or (= cfrom zero)
+ (multiple-value-bind (ret-val var-0)
+ (disnan cfrom) (declare (ignore))
+ (when var-0 (setf cfrom var-0)) ret-val))
+ (setf info -4))
+ ((multiple-value-bind (ret-val var-0) (disnan cto) (declare (ignore))
+ (when var-0 (setf cto var-0)) ret-val)
+ (setf info -5))
+ ((< 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 f2cl-lib:integer4 1) (the f2cl-lib:integer4 m))))
+ (setf info -9))
+ ((>= itype 4)
+ (cond
+ ((or (< kl 0)
+ (> kl
+ (max (the f2cl-lib:integer4
+ (f2cl-lib:int-add m (f2cl-lib:int-sub 1)))
+ (the f2cl-lib:integer4 0))))
+ (setf info -2))
+ ((or (< ku 0)
+ (> ku
+ (max (the f2cl-lib:integer4
+ (f2cl-lib:int-add n (f2cl-lib:int-sub 1)))
+ (the f2cl-lib:integer4 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 "ZLASCL" (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))
+ (cond
+ ((= cfrom1 cfromc)
+ (setf mul (/ ctoc cfromc))
+ (setf done f2cl-lib:%true%)
+ (setf cto1 ctoc))
+ (t (setf cto1 (/ ctoc bignum))
+ (cond
+ ((= cto1 ctoc) (setf mul ctoc) (setf done f2cl-lib:%true%)
+ (setf cfromc one))
+ ((and (> (abs cfrom1) (abs ctoc)) (/= ctoc zero)) (setf mul smlnum)
+ (setf done f2cl-lib:%false%) (setf cfromc cfrom1))
+ ((> (abs cto1) (abs cfromc))
+ (setf mul bignum)
+ (setf done f2cl-lib:%false%)
+ (setf ctoc cto1))
+ (t (setf mul (/ ctoc cfromc)) (setf done f2cl-lib:%true%)))))
+ (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))
+ label20))
+ label30)))
+ ((= 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))
+ label40))
+ label50)))
+ ((= 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 f2cl-lib:integer4 j)
+ (the f2cl-lib:integer4 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))
+ label60))
+ label70)))
+ ((= 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 f2cl-lib:integer4 (f2cl-lib:int-add j 1))
+ (the f2cl-lib:integer4 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))
+ label80))
+ label90)))
+ ((= 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 f2cl-lib:integer4 k3)
+ (the f2cl-lib:integer4
+ (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))
+ label100))
+ label110)))
+ ((= 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 f2cl-lib:integer4
+ (f2cl-lib:int-add k1 (f2cl-lib:int-sub j)))
+ (the f2cl-lib:integer4 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))
+ label120))
+ label130)))
+ ((= 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 f2cl-lib:integer4
+ (f2cl-lib:int-add k1 (f2cl-lib:int-sub j)))
+ (the f2cl-lib:integer4 k2))
+ (f2cl-lib:int-add i 1))
+ ((> i
+ (min (the f2cl-lib:integer4 k3)
+ (the f2cl-lib:integer4
+ (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))
+ label140))
+ label150))))
+ (if (not done) (go label10)) (go end_label) end_label
+ (return (values type nil nil cfrom cto nil nil nil nil info))))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -117125,7 +128590,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlaset.f}
* =====================================================================
SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
*
@@ -117206,10 +128671,94 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlaset}
-
+(defun zlaset (uplo m n alpha beta a lda)
+ (declare (type (simple-array character (*)) uplo)
+ (type (f2cl-lib:integer4) lda n m) (type (f2cl-lib:complex16) beta alpha)
+ (type (array f2cl-lib:complex16 (*)) a))
+ (f2cl-lib:with-multi-array-data
+ ((a f2cl-lib:complex16 a-%data% a-%offset%)
+ (uplo character uplo-%data% uplo-%offset%))
+ (prog ((i 0) (j 0))
+ (declare (type (f2cl-lib:integer4) j i))
+ (cond
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame uplo "U")
+ (declare (ignore var-1)) (when var-0 (setf uplo var-0)) ret-val)
+ (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 f2cl-lib:integer4
+ (f2cl-lib:int-add j (f2cl-lib:int-sub 1)))
+ (the f2cl-lib:integer4 m)))
+ nil)
+ (tagbody
+ (setf (f2cl-lib:fref a-%data% (i j)
+ ((1 lda) (1 *)) a-%offset%) alpha)
+ label10))
+ label20))
+ (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
+ ((> i
+ (min (the f2cl-lib:integer4 n)
+ (the f2cl-lib:integer4 m)))
+ nil)
+ (tagbody
+ (setf (f2cl-lib:fref a-%data% (i i)
+ ((1 lda) (1 *)) a-%offset%) beta)
+ label30)))
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame uplo "L")
+ (declare (ignore var-1)) (when var-0 (setf uplo var-0)) ret-val)
+ (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
+ ((> j
+ (min (the f2cl-lib:integer4 m)
+ (the f2cl-lib:integer4 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)
+ label40))
+ label50))
+ (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
+ ((> i
+ (min (the f2cl-lib:integer4 n)
+ (the f2cl-lib:integer4 m)))
+ nil)
+ (tagbody
+ (setf (f2cl-lib:fref a-%data% (i i)
+ ((1 lda) (1 *)) a-%offset%) beta)
+ label60)))
+ (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)
+ label70))
+ label80))
+ (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
+ ((> i
+ (min (the f2cl-lib:integer4 m)
+ (the f2cl-lib:integer4 n)))
+ nil)
+ (tagbody
+ (setf (f2cl-lib:fref a-%data% (i i)
+ ((1 lda) (1 *)) a-%offset%) beta)
+ label90))))
+ (go end_label)
+ end_label
+ (return (values uplo nil nil nil nil nil nil)))
+ ))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -117320,7 +128869,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlassq.f}
* =====================================================================
SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ )
*
@@ -117381,7 +128930,7 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlassq}
(let* ((zero 0.0))
@@ -117406,11 +128955,13 @@ Man Page Details
nil)
(tagbody
(cond
- ((/= (coerce (realpart (f2cl-lib:fref x (ix) ((1 *)))) 'double-float) zero)
+ ((/= (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)))
+ (f2cl-lib:fref x-%data% (ix)
+ ((1 *)) x-%offset%)) 'double-float)))
(cond
((< scale temp1)
(setf sumsq (+ 1 (* sumsq (expt (/ scale temp1) 2))))
@@ -117664,7 +129215,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zlatrs.f}
* =====================================================================
SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE,
$ CNORM, INFO )
@@ -118395,10 +129946,737 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zlatrs}
-
+(let* ((zero 0.0d0) (half 0.5d0) (one 1.0d0) (two 2.0d0))
+ (declare (type (double-float 0.0d0 0.0d0) zero)
+ (type (double-float 0.5d0 0.5d0) half) (type (double-float 1.0d0 1.0d0) one)
+ (type (double-float 2.0d0 2.0d0) two) (ignorable zero half one two))
+ (defun zlatrs (uplo trans diag normin n a lda x scale cnorm info)
+ (declare (type (simple-array character (*)) normin diag trans uplo)
+ (type (f2cl-lib:integer4) info lda n)
+ (type (array f2cl-lib:complex16 (*)) x a) (type (double-float) scale)
+ (type (array double-float (*)) cnorm))
+ (f2cl-lib:with-multi-array-data
+ ((cnorm double-float cnorm-%data%
+ cnorm-%offset%)
+ (a f2cl-lib:complex16 a-%data% a-%offset%)
+ (x f2cl-lib:complex16 x-%data% x-%offset%)
+ (uplo character uplo-%data% uplo-%offset%)
+ (trans character trans-%data% trans-%offset%)
+ (diag character diag-%data% diag-%offset%)
+ (normin character normin-%data% normin-%offset%))
+ (labels
+ ((cabs1 (zdum) (+ (abs (f2cl-lib:dble zdum))
+ (abs (f2cl-lib:dimag zdum))))
+ (cabs2 (zdum)
+ (+ (abs (/ (f2cl-lib:dble zdum) 2.0d0))
+ (abs (/ (f2cl-lib:dimag zdum) 2.0d0)))))
+ (declare
+ (ftype (function (f2cl-lib:complex16)
+ (values double-float &rest t)) cabs1))
+ (declare
+ (ftype (function (f2cl-lib:complex16)
+ (values double-float &rest t)) cabs2))
+ (prog
+ ((csumj #C(0.0d0 0.0d0)) (tjjs #C(0.0d0 0.0d0))
+ (uscal #C(0.0d0 0.0d0))
+ (zdum #C(0.0d0 0.0d0)) (bignum 0.0d0) (grow 0.0d0) (rec 0.0d0)
+ (smlnum 0.0d0) (tjj 0.0d0) (tmax 0.0d0) (tscal 0.0d0) (xbnd 0.0d0)
+ (xj 0.0d0) (xmax 0.0d0) (i 0) (imax 0) (j 0) (jfirst 0)
+ (jinc 0) (jlast 0)
+ (notran nil) (nounit nil) (upper nil))
+ (declare (type (f2cl-lib:complex16) zdum uscal tjjs csumj)
+ (type (double-float) xmax xj xbnd tscal tmax tjj
+ smlnum rec grow bignum)
+ (type (f2cl-lib:integer4) jlast jinc jfirst j imax i)
+ (type f2cl-lib:logical upper nounit notran))
+ (setf info 0)
+ (setf upper
+ (multiple-value-bind (ret-val var-0 var-1) (lsame uplo "U")
+ (declare (ignore var-1)) (when var-0 (setf uplo var-0)) ret-val))
+ (setf notran
+ (multiple-value-bind (ret-val var-0 var-1) (lsame trans "N")
+ (declare (ignore var-1)) (when var-0 (setf trans var-0)) ret-val))
+ (setf nounit
+ (multiple-value-bind (ret-val var-0 var-1) (lsame diag "N")
+ (declare (ignore var-1)) (when var-0 (setf diag var-0)) ret-val))
+ (cond
+ ((and (not upper)
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame uplo "L")
+ (declare (ignore var-1))
+ (when var-0 (setf uplo var-0)) ret-val)))
+ (setf info -1))
+ ((and (not notran)
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame trans "T")
+ (declare (ignore var-1))
+ (when var-0 (setf trans var-0)) ret-val))
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame trans "C")
+ (declare (ignore var-1))
+ (when var-0 (setf trans var-0)) ret-val)))
+ (setf info -2))
+ ((and (not nounit)
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame diag "U")
+ (declare (ignore var-1))
+ (when var-0 (setf diag var-0)) ret-val)))
+ (setf info -3))
+ ((and
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame normin "Y")
+ (declare (ignore var-1))
+ (when var-0 (setf normin var-0)) ret-val))
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame normin "N")
+ (declare (ignore var-1))
+ (when var-0 (setf normin var-0)) ret-val)))
+ (setf info -4))
+ ((< n 0) (setf info -5))
+ ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n)))
+ (setf info -7)))
+ (cond ((/= info 0)
+ (xerbla "ZLATRS" (f2cl-lib:int-sub info)) (go end_label)))
+ (if (= n 0) (go end_label)) (setf smlnum (dlamch "Safe minimum"))
+ (setf bignum (/ one smlnum))
+ (multiple-value-bind (var-0 var-1)
+ (dlabad smlnum bignum) (declare (ignore))
+ (when var-0 (setf smlnum var-0)) (when var-1 (setf bignum var-1)))
+ (setf smlnum (/ smlnum (dlamch "Precision")))
+ (setf bignum (/ one smlnum))
+ (setf scale one)
+ (cond
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame normin "N")
+ (declare (ignore var-1)) (when var-0 (setf normin var-0)) ret-val)
+ (cond
+ (upper
+ (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
+ ((> j n) nil)
+ (tagbody
+ (setf (f2cl-lib:fref cnorm-%data% (j)
+ ((1 *)) cnorm-%offset%)
+ (dzasum (f2cl-lib:int-sub j 1)
+ (f2cl-lib:array-slice a-%data%
+ f2cl-lib:complex16 (1 j)
+ ((1 lda) (1 *)) a-%offset%)
+ 1))
+ label10)))
+ (t
+ (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 (f2cl-lib:fref cnorm-%data% (j)
+ ((1 *)) cnorm-%offset%)
+ (dzasum (f2cl-lib:int-sub n j)
+ (f2cl-lib:array-slice a-%data%
+ f2cl-lib:complex16 ((+ j 1) j)
+ ((1 lda) (1 *)) a-%offset%)
+ 1))
+ label20))
+ (setf (f2cl-lib:fref cnorm-%data% (n)
+ ((1 *)) cnorm-%offset%) zero)))))
+ (setf imax
+ (multiple-value-bind (ret-val var-0 var-1 var-2) (idamax n cnorm 1)
+ (declare (ignore var-1 var-2)) (when var-0 (setf n var-0)) ret-val))
+ (setf tmax (f2cl-lib:fref cnorm-%data% (imax) ((1 *)) cnorm-%offset%))
+ (cond ((<= tmax (* bignum half)) (setf tscal one))
+ (t (setf tscal (/ half (* smlnum tmax)))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (dscal n tscal cnorm 1)
+ (declare (ignore var-2 var-3)) (when var-0 (setf n var-0))
+ (when var-1 (setf tscal var-1)))))
+ (setf xmax zero)
+ (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
+ ((> j n) nil)
+ (tagbody
+ (setf xmax
+ (max xmax (cabs2 (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%))))
+ label30))
+ (setf xbnd xmax)
+ (cond
+ (notran
+ (tagbody
+ (cond (upper (setf jfirst n) (setf jlast 1) (setf jinc -1))
+ (t (setf jfirst 1) (setf jlast n) (setf jinc 1)))
+ (cond ((/= tscal one) (setf grow zero) (go label60)))
+ (cond
+ (nounit (setf grow (/ half (max xbnd smlnum))) (setf xbnd grow)
+ (f2cl-lib:fdo (j jfirst (f2cl-lib:int-add j jinc))
+ ((> j jlast) nil)
+ (tagbody
+ (if (<= grow smlnum) (go label60))
+ (setf tjjs (f2cl-lib:fref a-%data% (j j)
+ ((1 lda) (1 *)) a-%offset%))
+ (setf tjj (cabs1 tjjs))
+ (cond ((>= tjj smlnum)
+ (setf xbnd (min xbnd (* (min one tjj) grow))))
+ (t (setf xbnd zero)))
+ (cond
+ ((>= (+ tjj (f2cl-lib:fref cnorm (j)
+ ((1 *)))) smlnum)
+ (setf grow
+ (* grow
+ (/ tjj
+ (+ tjj
+ (f2cl-lib:fref cnorm-%data% (j)
+ ((1 *)) cnorm-%offset%))))))
+ (t (setf grow zero)))
+ label40))
+ (setf grow xbnd))
+ (t (setf grow (min one (/ half (max xbnd smlnum))))
+ (f2cl-lib:fdo (j jfirst (f2cl-lib:int-add j jinc))
+ ((> j jlast) nil)
+ (tagbody
+ (if (<= grow smlnum) (go label60))
+ (setf grow
+ (* grow
+ (/ one
+ (+ one (f2cl-lib:fref cnorm-%data% (j)
+ ((1 *)) cnorm-%offset%)))))
+ label50))))
+ label60))
+ (t
+ (tagbody
+ (cond (upper (setf jfirst 1) (setf jlast n) (setf jinc 1))
+ (t (setf jfirst n) (setf jlast 1) (setf jinc -1)))
+ (cond ((/= tscal one) (setf grow zero) (go label90)))
+ (cond
+ (nounit (setf grow (/ half (max xbnd smlnum))) (setf xbnd grow)
+ (f2cl-lib:fdo (j jfirst (f2cl-lib:int-add j jinc))
+ ((> j jlast) nil)
+ (tagbody
+ (if (<= grow smlnum) (go label90))
+ (setf xj
+ (+ one (f2cl-lib:fref cnorm-%data% (j)
+ ((1 *)) cnorm-%offset%)))
+ (setf grow (min grow (/ xbnd xj)))
+ (setf tjjs (f2cl-lib:fref a-%data% (j j)
+ ((1 lda) (1 *)) a-%offset%))
+ (setf tjj (cabs1 tjjs))
+ (cond ((>= tjj smlnum)
+ (if (> xj tjj)
+ (setf xbnd (* xbnd (/ tjj xj)))))
+ (t (setf xbnd zero)))
+ label70))
+ (setf grow (min grow xbnd)))
+ (t (setf grow (min one (/ half (max xbnd smlnum))))
+ (f2cl-lib:fdo (j jfirst (f2cl-lib:int-add j jinc))
+ ((> j jlast) nil)
+ (tagbody
+ (if (<= grow smlnum) (go label90))
+ (setf xj
+ (+ one (f2cl-lib:fref cnorm-%data% (j)
+ ((1 *)) cnorm-%offset%)))
+ (setf grow (/ grow xj)) label80))))
+ label90)))
+ (cond
+ ((> (* grow tscal) smlnum)
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4
+ var-5 var-6 var-7)
+ (ztrsv uplo trans diag n a lda x 1)
+ (declare (ignore var-4 var-6 var-7))
+ (when var-0 (setf uplo var-0)) (when var-1 (setf trans var-1))
+ (when var-2 (setf diag var-2)) (when var-3 (setf n var-3))
+ (when var-5 (setf lda var-5))))
+ (t
+ (cond
+ ((> xmax (* bignum half)) (setf scale (/ (* bignum half) xmax))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zdscal n scale x 1)
+ (declare (ignore var-2 var-3)) (when var-0 (setf n var-0))
+ (when var-1 (setf scale var-1)))
+ (setf xmax bignum))
+ (t (setf xmax (* xmax two))))
+ (cond
+ (notran
+ (f2cl-lib:fdo (j jfirst (f2cl-lib:int-add j jinc))
+ ((> j jlast) nil)
+ (tagbody
+ (setf xj (cabs1 (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)))
+ (cond
+ (nounit
+ (setf tjjs
+ (* (f2cl-lib:fref a-%data% (j j)
+ ((1 lda) (1 *)) a-%offset%) tscal)))
+ (t (setf tjjs (coerce tscal 'f2cl-lib:complex16))
+ (if (= tscal one) (go label110))))
+ (setf tjj (cabs1 tjjs))
+ (cond
+ ((> tjj smlnum)
+ (cond
+ ((< tjj one)
+ (cond
+ ((> xj (* tjj bignum)) (setf rec (/ one xj))
+ (multiple-value-bind (var-0 var-1 var-2
+ var-3)
+ (zdscal n rec x 1)
+ (declare (ignore var-2 var-3))
+ (when var-0 (setf n var-0))
+ (when var-1 (setf rec var-1)))
+ (setf scale (* scale rec))
+ (setf xmax (* xmax rec))))))
+ (setf (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)
+ (zladiv (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%) tjjs))
+ (setf xj (cabs1 (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%))))
+ ((> tjj zero)
+ (cond
+ ((> xj (* tjj bignum))
+ (setf rec (/ (* tjj bignum) xj))
+ (cond
+ ((> (f2cl-lib:fref cnorm (j) ((1 *))) one)
+ (setf rec
+ (/ rec
+ (f2cl-lib:fref cnorm-%data% (j)
+ ((1 *)) cnorm-%offset%)))))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zdscal n rec x 1)
+ (declare (ignore var-2 var-3))
+ (when var-0 (setf n var-0))
+ (when var-1 (setf rec var-1)))
+ (setf scale (* scale rec))
+ (setf xmax (* xmax rec))))
+ (setf (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)
+ (zladiv (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%) tjjs))
+ (setf xj (cabs1
+ (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%))))
+ (t
+ (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%)
+ (coerce zero 'f2cl-lib:complex16))
+ label100))
+ (setf (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)
+ (coerce one 'f2cl-lib:complex16))
+ (setf xj one)
+ (setf scale zero)
+ (setf xmax zero)))
+ label110
+ (cond
+ ((> xj one) (setf rec (/ one xj))
+ (cond
+ ((> (f2cl-lib:fref cnorm (j) ((1 *)))
+ (* (+ bignum (- xmax)) rec))
+ (setf rec (* rec half))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zdscal n rec x 1)
+ (declare (ignore var-2 var-3))
+ (when var-0 (setf n var-0))
+ (when var-1 (setf rec var-1)))
+ (setf scale (* scale rec)))))
+ ((> (* xj (f2cl-lib:fref cnorm (j)
+ ((1 *)))) (+ bignum (- xmax)))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zdscal n half x 1)
+ (declare (ignore var-2 var-3))
+ (when var-0 (setf n var-0))
+ (when var-1 (setf half var-1)))
+ (setf scale (* scale half))))
+ (cond
+ (upper
+ (cond
+ ((> j 1)
+ (zaxpy (f2cl-lib:int-sub j 1)
+ (* (- (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)) tscal)
+ (f2cl-lib:array-slice a-%data%
+ f2cl-lib:complex16 (1 j)
+ ((1 lda) (1 *)) a-%offset%)
+ 1 x 1)
+ (setf i (izamax (f2cl-lib:int-sub j 1) x 1))
+ (setf xmax
+ (cabs1 (f2cl-lib:fref x-%data% (i)
+ ((1 *)) x-%offset%))))))
+ (t
+ (cond
+ ((< j n)
+ (zaxpy (f2cl-lib:int-sub n j)
+ (* (- (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)) tscal)
+ (f2cl-lib:array-slice a-%data%
+ f2cl-lib:complex16 ((+ j 1) j)
+ ((1 lda) (1 *)) a-%offset%)
+ 1
+ (f2cl-lib:array-slice x-%data%
+ f2cl-lib:complex16 ((+ j 1)) ((1 *))
+ x-%offset%)
+ 1)
+ (setf i
+ (f2cl-lib:int-add j
+ (izamax (f2cl-lib:int-sub n j)
+ (f2cl-lib:array-slice x-%data%
+ f2cl-lib:complex16 ((+ j 1))
+ ((1 *)) x-%offset%)
+ 1)))
+ (setf xmax
+ (cabs1 (f2cl-lib:fref x-%data% (i)
+ ((1 *)) x-%offset%)))))))
+ label120)))
+ ((multiple-value-bind (ret-val var-0 var-1) (lsame trans "T")
+ (declare (ignore var-1)) (when var-0 (setf trans var-0)) ret-val)
+ (f2cl-lib:fdo (j jfirst (f2cl-lib:int-add j jinc))
+ ((> j jlast) nil)
+ (tagbody
+ (setf xj (cabs1 (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)))
+ (setf uscal (coerce tscal 'f2cl-lib:complex16))
+ (setf rec (/ one (max xmax one)))
+ (cond
+ ((> (f2cl-lib:fref cnorm (j)
+ ((1 *))) (* (+ bignum (- xj)) rec))
+ (setf rec (* rec half))
+ (cond
+ (nounit
+ (setf tjjs
+ (* (f2cl-lib:fref a-%data% (j j)
+ ((1 lda) (1 *)) a-%offset%)
+ tscal)))
+ (t (setf tjjs
+ (coerce tscal 'f2cl-lib:complex16))))
+ (setf tjj (cabs1 tjjs))
+ (cond
+ ((> tjj one) (setf rec (min one (* rec tjj)))
+ (setf uscal (zladiv uscal tjjs))))
+ (cond
+ ((< rec one)
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zdscal n rec x 1)
+ (declare (ignore var-2 var-3))
+ (when var-0 (setf n var-0))
+ (when var-1 (setf rec var-1)))
+ (setf scale (* scale rec))
+ (setf xmax (* xmax rec))))))
+ (setf csumj (coerce zero 'f2cl-lib:complex16))
+ (cond
+ ((= uscal (f2cl-lib:dcmplx one))
+ (cond
+ (upper
+ (setf csumj
+ (zdotu (f2cl-lib:int-sub j 1)
+ (f2cl-lib:array-slice a-%data%
+ f2cl-lib:complex16 (1 j)
+ ((1 lda) (1 *)) a-%offset%)
+ 1 x 1)))
+ ((< j n)
+ (setf csumj
+ (zdotu (f2cl-lib:int-sub n j)
+ (f2cl-lib:array-slice a-%data%
+ f2cl-lib:complex16 ((+ j 1) j)
+ ((1 lda) (1 *)) a-%offset%)
+ 1
+ (f2cl-lib:array-slice x-%data%
+ f2cl-lib:complex16 ((+ j 1))
+ ((1 *)) x-%offset%)
+ 1)))))
+ (t
+ (cond
+ (upper
+ (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 csumj
+ (+ csumj
+ (* (f2cl-lib:fref a-%data% (i j)
+ ((1 lda) (1 *)) a-%offset%)
+ uscal (f2cl-lib:fref x-%data% (i)
+ ((1 *)) x-%offset%))))
+ label130)))
+ ((< j n)
+ (f2cl-lib:fdo (i (f2cl-lib:int-add j 1)
+ (f2cl-lib:int-add i 1))
+ ((> i
+ n)
+ nil)
+ (tagbody
+ (setf csumj
+ (+ csumj
+ (* (f2cl-lib:fref a-%data% (i j)
+ ((1 lda) (1 *)) a-%offset%)
+ uscal (f2cl-lib:fref x-%data% (i)
+ ((1 *)) x-%offset%))))
+ label140))))))
+ (cond
+ ((= uscal (f2cl-lib:dcmplx tscal))
+ (tagbody
+ (setf (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)
+ (- (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%) csumj))
+ (setf xj (cabs1 (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)))
+ (cond
+ (nounit
+ (setf tjjs
+ (* (f2cl-lib:fref a-%data% (j j)
+ ((1 lda) (1 *)) a-%offset%)
+ tscal)))
+ (t (setf tjjs
+ (coerce tscal 'f2cl-lib:complex16))
+ (if (= tscal one) (go label160))))
+ (setf tjj (cabs1 tjjs))
+ (cond
+ ((> tjj smlnum)
+ (cond
+ ((< tjj one)
+ (cond
+ ((> xj (* tjj bignum))
+ (setf rec (/ one xj))
+ (multiple-value-bind (var-0 var-1
+ var-2 var-3)
+ (zdscal n rec x 1)
+ (declare (ignore var-2 var-3))
+ (when var-0 (setf n var-0))
+ (when var-1 (setf rec var-1)))
+ (setf scale (* scale rec))
+ (setf xmax (* xmax rec))))))
+ (setf (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)
+ (zladiv (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%) tjjs)))
+ ((> tjj zero)
+ (cond
+ ((> xj (* tjj bignum))
+ (setf rec (/ (* tjj bignum) xj))
+ (multiple-value-bind (var-0 var-1 var-2
+ var-3)
+ (zdscal n rec x 1)
+ (declare (ignore var-2 var-3))
+ (when var-0 (setf n var-0))
+ (when var-1 (setf rec var-1)))
+ (setf scale (* scale rec))
+ (setf xmax (* xmax rec))))
+ (setf (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)
+ (zladiv (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%) tjjs)))
+ (t
+ (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%)
+ (coerce zero 'f2cl-lib:complex16))
+ label150))
+ (setf (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)
+ (coerce one 'f2cl-lib:complex16))
+ (setf scale zero) (setf xmax zero)))
+ label160))
+ (t
+ (setf (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)
+ (- (zladiv (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%) tjjs)
+ csumj))))
+ (setf xmax
+ (max xmax (cabs1
+ (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%))))
+ label170)))
+ (t
+ (f2cl-lib:fdo (j jfirst (f2cl-lib:int-add j jinc))
+ ((> j jlast) nil)
+ (tagbody
+ (setf xj (cabs1 (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)))
+ (setf uscal (coerce tscal 'f2cl-lib:complex16))
+ (setf rec (/ one (max xmax one)))
+ (cond
+ ((> (f2cl-lib:fref cnorm (j) ((1 *)))
+ (* (+ bignum (- xj)) rec))
+ (setf rec (* rec half))
+ (cond
+ (nounit
+ (setf tjjs
+ (coerce
+ (*
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref a-%data% (j j)
+ ((1 lda) (1 *)) a-%offset%))
+ tscal)
+ 'f2cl-lib:complex16)))
+ (t
+ (setf tjjs
+ (coerce tscal 'f2cl-lib:complex16))))
+ (setf tjj (cabs1 tjjs))
+ (cond
+ ((> tjj one) (setf rec (min one (* rec tjj)))
+ (setf uscal (zladiv uscal tjjs))))
+ (cond
+ ((< rec one)
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zdscal n rec x 1)
+ (declare (ignore var-2 var-3))
+ (when var-0 (setf n var-0))
+ (when var-1 (setf rec var-1)))
+ (setf scale (* scale rec))
+ (setf xmax (* xmax rec))))))
+ (setf csumj (coerce zero 'f2cl-lib:complex16))
+ (cond
+ ((= uscal (f2cl-lib:dcmplx one))
+ (cond
+ (upper
+ (setf csumj
+ (zdotc (f2cl-lib:int-sub j 1)
+ (f2cl-lib:array-slice a-%data%
+ f2cl-lib:complex16 (1 j)
+ ((1 lda) (1 *)) a-%offset%)
+ 1 x 1)))
+ ((< j n)
+ (setf csumj
+ (zdotc (f2cl-lib:int-sub n j)
+ (f2cl-lib:array-slice a-%data%
+ f2cl-lib:complex16 ((+ j 1) j)
+ ((1 lda) (1 *)) a-%offset%)
+ 1
+ (f2cl-lib:array-slice x-%data%
+ f2cl-lib:complex16 ((+ j 1))
+ ((1 *)) x-%offset%)
+ 1)))))
+ (t
+ (cond
+ (upper
+ (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 csumj
+ (+ csumj
+ (*
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref a-%data% (i j)
+ ((1 lda) (1 *)) a-%offset%))
+ uscal (f2cl-lib:fref x-%data% (i)
+ ((1 *)) x-%offset%))))
+ label180)))
+ ((< j n)
+ (f2cl-lib:fdo (i (f2cl-lib:int-add j 1)
+ (f2cl-lib:int-add i 1))
+ ((> i
+ n)
+ nil)
+ (tagbody
+ (setf csumj
+ (+ csumj
+ (*
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref a-%data% (i j)
+ ((1 lda) (1 *)) a-%offset%))
+ uscal (f2cl-lib:fref x-%data% (i)
+ ((1 *)) x-%offset%))))
+ label190))))))
+ (cond
+ ((= uscal (f2cl-lib:dcmplx tscal))
+ (tagbody
+ (setf (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)
+ (- (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%) csumj))
+ (setf xj (cabs1 (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)))
+ (cond
+ (nounit
+ (setf tjjs
+ (coerce
+ (*
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref a-%data% (j j)
+ ((1 lda) (1 *)) a-%offset%))
+ tscal)
+ 'f2cl-lib:complex16)))
+ (t (setf tjjs
+ (coerce tscal 'f2cl-lib:complex16))
+ (if (= tscal one) (go label210))))
+ (setf tjj (cabs1 tjjs))
+ (cond
+ ((> tjj smlnum)
+ (cond
+ ((< tjj one)
+ (cond
+ ((> xj (* tjj bignum))
+ (setf rec (/ one xj))
+ (multiple-value-bind (var-0 var-1
+ var-2 var-3)
+ (zdscal n rec x 1)
+ (declare (ignore var-2 var-3))
+ (when var-0 (setf n var-0))
+ (when var-1 (setf rec var-1)))
+ (setf scale (* scale rec))
+ (setf xmax (* xmax rec))))))
+ (setf (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)
+ (zladiv (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%) tjjs)))
+ ((> tjj zero)
+ (cond
+ ((> xj (* tjj bignum))
+ (setf rec (/ (* tjj bignum) xj))
+ (multiple-value-bind (var-0 var-1 var-2
+ var-3)
+ (zdscal n rec x 1)
+ (declare (ignore var-2 var-3))
+ (when var-0 (setf n var-0))
+ (when var-1 (setf rec var-1)))
+ (setf scale (* scale rec))
+ (setf xmax (* xmax rec))))
+ (setf (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)
+ (zladiv (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%) tjjs)))
+ (t
+ (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%)
+ (coerce zero 'f2cl-lib:complex16))
+ label200))
+ (setf (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)
+ (coerce one 'f2cl-lib:complex16))
+ (setf scale zero) (setf xmax zero)))
+ label210))
+ (t
+ (setf (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%)
+ (- (zladiv (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%) tjjs)
+ csumj))))
+ (setf xmax
+ (max xmax (cabs1 (f2cl-lib:fref x-%data% (j)
+ ((1 *)) x-%offset%))))
+ label220))))
+ (setf scale (/ scale tscal))))
+ (cond
+ ((/= tscal one)
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (dscal n (/ one tscal) cnorm 1)
+ (declare (ignore var-1 var-2 var-3))
+ (when var-0 (setf n var-0)))))
+ (go end_label) end_label
+ (return
+ (values uplo trans diag normin n nil lda nil scale nil info))))
+ )))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -118504,7 +130782,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zrot.f}
* =====================================================================
SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S )
*
@@ -118566,10 +130844,60 @@ Man Page Details
RETURN
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zrot}
-
+(defun zrot (n cx incx cy incy c s)
+ (declare (type (f2cl-lib:integer4) incy incx n)
+ (type (array f2cl-lib:complex16 (*)) cy cx) (type (double-float) c)
+ (type (f2cl-lib:complex16) s))
+ (f2cl-lib:with-multi-array-data
+ ((cx f2cl-lib:complex16 cx-%data% cx-%offset%)
+ (cy f2cl-lib:complex16 cy-%data% cy-%offset%))
+ (prog
+ ((stemp #C(0.0d0 0.0d0)) (i 0) (ix 0) (iy 0))
+ (declare (type (f2cl-lib:complex16) stemp)
+ (type (f2cl-lib:integer4) 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 stemp
+ (+ (* c (f2cl-lib:fref cx-%data% (ix) ((1 *)) cx-%offset%))
+ (* s (f2cl-lib:fref cy-%data% (iy) ((1 *)) cy-%offset%))))
+ (setf (f2cl-lib:fref cy-%data% (iy) ((1 *)) cy-%offset%)
+ (- (* c (f2cl-lib:fref cy-%data% (iy) ((1 *)) cy-%offset%))
+ (* (f2cl-lib:dconjg s)
+ (f2cl-lib:fref cx-%data% (ix) ((1 *)) cx-%offset%))))
+ (setf (f2cl-lib:fref cx-%data% (ix) ((1 *))
+ cx-%offset%) stemp)
+ (setf ix (f2cl-lib:int-add ix incx))
+ (setf iy (f2cl-lib:int-add iy incy))
+ label10))
+ (go end_label) label20
+ (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
+ ((> i n) nil)
+ (tagbody
+ (setf stemp
+ (+ (* c (f2cl-lib:fref cx-%data% (i) ((1 *)) cx-%offset%))
+ (* s (f2cl-lib:fref cy-%data% (i) ((1 *)) cy-%offset%))))
+ (setf (f2cl-lib:fref cy-%data% (i) ((1 *)) cy-%offset%)
+ (- (* c (f2cl-lib:fref cy-%data% (i) ((1 *)) cy-%offset%))
+ (* (f2cl-lib:dconjg s)
+ (f2cl-lib:fref cx-%data% (i) ((1 *)) cx-%offset%))))
+ (setf (f2cl-lib:fref cx-%data% (i) ((1 *)) cx-%offset%)
+ stemp) label30)
+ )
+ (go end_label) end_label (return (values nil nil nil nil nil nil nil)))
+ ))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -118778,7 +131106,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{ztrevc.f}
* =====================================================================
SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
$ LDVR, MM, M, WORK, RWORK, INFO )
@@ -119050,10 +131378,471 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK ztrevc}
-
+(let*
+ ((zero 0.0d0) (one 1.0d0)
+ (cmzero (coerce (f2cl-lib:cmplx 0.0d0 0.0d0) 'f2cl-lib:complex16))
+ (cmone (coerce (f2cl-lib:cmplx 1.0d0 0.0d0) 'f2cl-lib:complex16)))
+ (declare (type (double-float 0.0d0 0.0d0) zero)
+ (type (double-float 1.0d0 1.0d0) one) (type (f2cl-lib:complex16) cmzero)
+ (type (f2cl-lib:complex16) cmone) (ignorable zero one cmzero cmone))
+ (defun ztrevc
+ (side howmny select n t$ ldt vl ldvl vr ldvr mm m work rwork info)
+ (declare (type (simple-array character (*)) howmny side)
+ (type (array f2cl-lib:logical (*)) select)
+ (type (f2cl-lib:integer4) info m mm ldvr ldvl ldt n)
+ (type (array f2cl-lib:complex16 (*)) work vr vl t$)
+ (type (array double-float (*)) rwork))
+ (f2cl-lib:with-multi-array-data
+ ((rwork double-float rwork-%data%
+ rwork-%offset%)
+ (t$ f2cl-lib:complex16 t$-%data% t$-%offset%)
+ (vl f2cl-lib:complex16 vl-%data% vl-%offset%)
+ (vr f2cl-lib:complex16 vr-%data% vr-%offset%)
+ (work f2cl-lib:complex16 work-%data% work-%offset%)
+ (select f2cl-lib:logical select-%data% select-%offset%)
+ (side character side-%data% side-%offset%)
+ (howmny character howmny-%data% howmny-%offset%))
+ (labels
+ ((cabs1 (cdum)
+ (+ (abs (f2cl-lib:dble cdum)) (abs (f2cl-lib:dimag cdum)))))
+ (declare
+ (ftype (function (f2cl-lib:complex16)
+ (values double-float &rest t)) cabs1))
+ (prog
+ ((cdum #C(0.0d0 0.0d0)) (ovfl 0.0d0) (remax 0.0d0)
+ (scale 0.0d0) (smin 0.0d0)
+ (smlnum 0.0d0) (ulp 0.0d0) (unfl 0.0d0)
+ (i 0) (ii 0) (is 0) (j 0) (k 0)
+ (ki 0) (allv nil) (bothv nil) (leftv nil) (over nil) (rightv nil)
+ (somev nil) (dcmplx$ 0.0))
+ (declare (type (f2cl-lib:complex16) cdum)
+ (type (double-float) unfl ulp smlnum smin scale remax ovfl)
+ (type (f2cl-lib:integer4) ki k j is ii i)
+ (type f2cl-lib:logical somev rightv over leftv bothv allv)
+ (type (single-float) dcmplx$))
+ (setf bothv
+ (multiple-value-bind (ret-val var-0 var-1) (lsame side "B")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val))
+ (setf rightv
+ (or
+ (multiple-value-bind (ret-val var-0 var-1) (lsame side "R")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val)
+ bothv))
+ (setf leftv
+ (or
+ (multiple-value-bind (ret-val var-0 var-1) (lsame side "L")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val)
+ bothv))
+ (setf allv
+ (multiple-value-bind (ret-val var-0 var-1) (lsame howmny "A")
+ (declare (ignore var-1)) (when var-0 (setf howmny var-0)) ret-val))
+ (setf over
+ (multiple-value-bind (ret-val var-0 var-1) (lsame howmny "B")
+ (declare (ignore var-1)) (when var-0 (setf howmny var-0)) ret-val))
+ (setf somev
+ (multiple-value-bind (ret-val var-0 var-1) (lsame howmny "S")
+ (declare (ignore var-1)) (when var-0 (setf howmny var-0)) ret-val))
+ (cond
+ (somev (setf m 0)
+ (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
+ ((> j n) nil)
+ (tagbody
+ (if (f2cl-lib:fref select-%data% (j)
+ ((1 *)) select-%offset%)
+ (setf m (f2cl-lib:int-add m 1)))
+ label10)))
+ (t (setf m n)))
+ (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 f2cl-lib:integer4 1) (the f2cl-lib:integer4 n)))
+ (setf info -6))
+ ((or (< ldvl 1) (and leftv (< ldvl n))) (setf info -8))
+ ((or (< ldvr 1) (and rightv (< ldvr n))) (setf info -10))
+ ((< mm m) (setf info -11)))
+ (cond ((/= info 0)
+ (xerbla "ZTREVC" (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))
+ (when var-0 (setf unfl var-0)) (when var-1 (setf ovfl var-1)))
+ (setf ulp (dlamch "Precision")) (setf smlnum (* unfl (/ n ulp)))
+ (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
+ ((> i n) nil)
+ (tagbody
+ (setf
+ (f2cl-lib:fref work-%data%
+ ((f2cl-lib:int-add i n)) ((1 *)) work-%offset%)
+ (f2cl-lib:fref t$-%data% (i i)
+ ((1 ldt) (1 *)) t$-%offset%))
+ label20))
+ (setf (f2cl-lib:fref rwork-%data% (1) ((1 *)) rwork-%offset%) zero)
+ (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1))
+ ((> j n) nil)
+ (tagbody
+ (setf (f2cl-lib:fref rwork-%data% (j)
+ ((1 *)) rwork-%offset%)
+ (dzasum (f2cl-lib:int-sub j 1)
+ (f2cl-lib:array-slice t$-%data%
+ f2cl-lib:complex16 (1 j) ((1 ldt) (1 *))
+ t$-%offset%)
+ 1))
+ label30))
+ (cond
+ (rightv (setf is m)
+ (f2cl-lib:fdo (ki n (f2cl-lib:int-add ki (f2cl-lib:int-sub 1)))
+ ((> ki 1)
+ nil)
+ (tagbody
+ (cond
+ (somev
+ (if (not (f2cl-lib:fref select-%data% (ki)
+ ((1 *)) select-%offset%))
+ (go label80))))
+ (setf smin
+ (max
+ (* ulp
+ (cabs1 (f2cl-lib:fref t$-%data% (ki ki)
+ ((1 ldt) (1 *)) t$-%offset%)))
+ smlnum))
+ (setf (f2cl-lib:fref work-%data% (1)
+ ((1 *)) work-%offset%) cmone)
+ (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% (k)
+ ((1 *)) work-%offset%)
+ (- (f2cl-lib:fref t$-%data% (k ki)
+ ((1 ldt) (1 *)) t$-%offset%)))
+ label40))
+ (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 t$-%data% (k k)
+ ((1 ldt) (1 *)) t$-%offset%)
+ (- (f2cl-lib:fref t$-%data% (k k)
+ ((1 ldt) (1 *)) t$-%offset%)
+ (f2cl-lib:fref t$-%data% (ki ki)
+ ((1 ldt) (1 *)) t$-%offset%)))
+ (if
+ (< (cabs1 (f2cl-lib:fref t$-%data% (k k)
+ ((1 ldt) (1 *)) t$-%offset%))
+ smin)
+ (setf (f2cl-lib:fref t$-%data% (k k)
+ ((1 ldt) (1 *)) t$-%offset%)
+ (coerce smin 'f2cl-lib:complex16)))
+ label50))
+ (cond
+ ((> ki 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)
+ (zlatrs "Upper" "No transpose" "Non-unit" "Y"
+ (f2cl-lib:int-sub ki 1)
+ t$ ldt
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 (1) ((1 *))
+ work-%offset%)
+ scale rwork info)
+ (declare (ignore var-0 var-1 var-2 var-3
+ var-4 var-5 var-7 var-9))
+ (setf ldt var-6)
+ (setf scale var-8)
+ (setf info var-10))
+ (setf (f2cl-lib:fref work-%data% (ki)
+ ((1 *)) work-%offset%)
+ (coerce scale 'f2cl-lib:complex16))))
+ (cond
+ ((not over)
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
+ (zcopy ki
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 (1) ((1 *))
+ work-%offset%)
+ 1
+ (f2cl-lib:array-slice vr-%data%
+ f2cl-lib:complex16 (1 is)
+ ((1 ldvr) (1 *)) vr-%offset%)
+ 1)
+ (declare (ignore var-1 var-2 var-3 var-4))
+ (when var-0 (setf ki var-0)))
+ (setf ii
+ (multiple-value-bind (ret-val var-0 var-1 var-2)
+ (izamax ki
+ (f2cl-lib:array-slice vr-%data%
+ f2cl-lib:complex16 (1 is)
+ ((1 ldvr) (1 *)) vr-%offset%)
+ 1)
+ (declare (ignore var-1 var-2))
+ (when var-0 (setf ki var-0)) ret-val))
+ (setf remax
+ (/ one
+ (cabs1
+ (f2cl-lib:fref vr-%data% (ii is)
+ ((1 ldvr) (1 *)) vr-%offset%))))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zdscal ki remax
+ (f2cl-lib:array-slice vr-%data%
+ f2cl-lib:complex16 (1 is)
+ ((1 ldvr) (1 *)) vr-%offset%)
+ 1)
+ (declare (ignore var-2 var-3))
+ (when var-0 (setf ki var-0))
+ (when var-1 (setf remax var-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%)
+ cmzero)
+ label60)))
+ (t
+ (if (> ki 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)
+ (zgemv "N" n (f2cl-lib:int-sub ki 1) cmone vr ldvr
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 (1) ((1 *))
+ work-%offset%)
+ 1 (f2cl-lib:dcmplx scale)
+ (f2cl-lib:array-slice vr-%data%
+ f2cl-lib:complex16 (1 ki)
+ ((1 ldvr) (1 *)) vr-%offset%)
+ 1)
+ (declare (ignore var-0 var-2 var-4 var-6
+ var-7 var-8 var-9 var-10))
+ (when var-1 (setf n var-1))
+ (when var-3 (setf cmone var-3))
+ (when var-5 (setf ldvr var-5))))
+ (setf ii
+ (multiple-value-bind (ret-val var-0 var-1 var-2)
+ (izamax n
+ (f2cl-lib:array-slice vr-%data%
+ f2cl-lib:complex16 (1 ki)
+ ((1 ldvr) (1 *)) vr-%offset%)
+ 1)
+ (declare (ignore var-1 var-2))
+ (when var-0 (setf n var-0)) ret-val))
+ (setf remax
+ (/ one
+ (cabs1
+ (f2cl-lib:fref vr-%data% (ii ki)
+ ((1 ldvr) (1 *)) vr-%offset%))))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zdscal n remax
+ (f2cl-lib:array-slice vr-%data%
+ f2cl-lib:complex16 (1 ki)
+ ((1 ldvr) (1 *)) vr-%offset%)
+ 1)
+ (declare (ignore var-2 var-3))
+ (when var-0 (setf n var-0))
+ (when var-1 (setf remax var-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 t$-%data% (k k)
+ ((1 ldt) (1 *)) t$-%offset%)
+ (f2cl-lib:fref work-%data%
+ ((f2cl-lib:int-add k n)) ((1 *))
+ work-%offset%))
+ label70))
+ (setf is (f2cl-lib:int-sub is 1)) label80))))
+ (cond
+ (leftv (setf is 1)
+ (f2cl-lib:fdo (ki 1 (f2cl-lib:int-add ki 1))
+ ((> ki n) nil)
+ (tagbody
+ (cond
+ (somev
+ (if (not (f2cl-lib:fref select-%data% (ki)
+ ((1 *)) select-%offset%))
+ (go label130))))
+ (setf smin
+ (max
+ (* ulp
+ (cabs1 (f2cl-lib:fref t$-%data% (ki ki)
+ ((1 ldt) (1 *)) t$-%offset%)))
+ smlnum))
+ (setf (f2cl-lib:fref work-%data% (n) ((1 *))
+ work-%offset%) cmone)
+ (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% (k)
+ ((1 *)) work-%offset%)
+ (coerce
+ (-
+ (f2cl-lib:dconjg
+ (f2cl-lib:fref t$-%data% (ki k)
+ ((1 ldt) (1 *)) t$-%offset%)))
+ 'f2cl-lib:complex16))
+ label90))
+ (f2cl-lib:fdo (k
+ (f2cl-lib:int-add ki 1) (f2cl-lib:int-add k 1))
+ ((> k n)
+ nil)
+ (tagbody
+ (setf (f2cl-lib:fref t$-%data% (k k)
+ ((1 ldt) (1 *)) t$-%offset%)
+ (- (f2cl-lib:fref t$-%data% (k k)
+ ((1 ldt) (1 *)) t$-%offset%)
+ (f2cl-lib:fref t$-%data% (ki ki)
+ ((1 ldt) (1 *)) t$-%offset%)))
+ (if
+ (< (cabs1 (f2cl-lib:fref t$-%data% (k k)
+ ((1 ldt) (1 *)) t$-%offset%))
+ smin)
+ (setf (f2cl-lib:fref t$-%data% (k k)
+ ((1 ldt) (1 *)) t$-%offset%)
+ (coerce smin 'f2cl-lib:complex16)))
+ label100))
+ (cond
+ ((< ki 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)
+ (zlatrs "Upper" "Conjugate transpose" "Non-unit" "Y"
+ (f2cl-lib:int-sub n ki)
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16
+ ((+ ki 1) (f2cl-lib:int-add ki 1))
+ ((1 ldt) (1 *)) t$-%offset%)
+ ldt
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 ((+ ki 1))
+ ((1 *)) work-%offset%)
+ scale rwork info)
+ (declare (ignore var-0 var-1 var-2 var-3
+ var-4 var-5 var-7 var-9))
+ (setf ldt var-6)
+ (setf scale var-8)
+ (setf info var-10))
+ (setf (f2cl-lib:fref work-%data% (ki)
+ ((1 *)) work-%offset%)
+ (coerce scale 'f2cl-lib:complex16))))
+ (cond
+ ((not over)
+ (zcopy (f2cl-lib:int-add (f2cl-lib:int-sub n ki) 1)
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 (ki) ((1 *))
+ work-%offset%)
+ 1
+ (f2cl-lib:array-slice vl-%data%
+ f2cl-lib:complex16 (ki is)
+ ((1 ldvl) (1 *)) vl-%offset%)
+ 1)
+ (setf ii
+ (f2cl-lib:int-sub
+ (f2cl-lib:int-add
+ (izamax (f2cl-lib:int-add
+ (f2cl-lib:int-sub n ki) 1)
+ (f2cl-lib:array-slice vl-%data%
+ f2cl-lib:complex16 (ki is)
+ ((1 ldvl) (1 *)) vl-%offset%)
+ 1)
+ ki)
+ 1))
+ (setf remax
+ (/ one
+ (cabs1
+ (f2cl-lib:fref vl-%data% (ii is)
+ ((1 ldvl) (1 *)) vl-%offset%))))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zdscal (f2cl-lib:int-add
+ (f2cl-lib:int-sub n ki) 1) remax
+ (f2cl-lib:array-slice vl-%data%
+ f2cl-lib:complex16 (ki is)
+ ((1 ldvl) (1 *)) vl-%offset%)
+ 1)
+ (declare (ignore var-0 var-2 var-3))
+ (when var-1 (setf remax var-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%)
+ cmzero)
+ label110)))
+ (t
+ (if (< ki 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)
+ (zgemv "N" n (f2cl-lib:int-sub n ki) cmone
+ (f2cl-lib:array-slice vl-%data% f2cl-lib:complex16
+ (1 (f2cl-lib:int-add ki 1))
+ ((1 ldvl) (1 *)) vl-%offset%)
+ ldvl
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 ((+ ki 1))
+ ((1 *)) work-%offset%)
+ 1 (f2cl-lib:dcmplx scale)
+ (f2cl-lib:array-slice vl-%data%
+ f2cl-lib:complex16 (1 ki)
+ ((1 ldvl) (1 *)) vl-%offset%)
+ 1)
+ (declare (ignore var-0 var-2 var-4 var-6
+ var-7 var-8 var-9 var-10))
+ (when var-1 (setf n var-1))
+ (when var-3 (setf cmone var-3))
+ (when var-5 (setf ldvl var-5))))
+ (setf ii
+ (multiple-value-bind (ret-val var-0 var-1 var-2)
+ (izamax n
+ (f2cl-lib:array-slice vl-%data%
+ f2cl-lib:complex16 (1 ki)
+ ((1 ldvl) (1 *)) vl-%offset%)
+ 1)
+ (declare (ignore var-1 var-2))
+ (when var-0 (setf n var-0)) ret-val))
+ (setf remax
+ (/ one
+ (cabs1
+ (f2cl-lib:fref vl-%data% (ii ki)
+ ((1 ldvl) (1 *)) vl-%offset%))))
+ (multiple-value-bind (var-0 var-1 var-2 var-3)
+ (zdscal n remax
+ (f2cl-lib:array-slice vl-%data%
+ f2cl-lib:complex16 (1 ki)
+ ((1 ldvl) (1 *)) vl-%offset%)
+ 1)
+ (declare (ignore var-2 var-3))
+ (when var-0 (setf n var-0))
+ (when var-1 (setf remax var-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 t$-%data% (k k)
+ ((1 ldt) (1 *)) t$-%offset%)
+ (f2cl-lib:fref work-%data%
+ ((f2cl-lib:int-add k n)) ((1 *))
+ work-%offset%))
+ label120))
+ (setf is (f2cl-lib:int-add is 1)) label130))))
+ (go end_label) end_label
+ (return
+ (values side howmny nil n nil ldt nil ldvl nil
+ ldvr nil m nil nil info))))
+ )))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -119178,7 +131967,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{ztrexc.f}
* =====================================================================
SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )
*
@@ -119296,10 +132085,109 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK ztrexc}
-
+(defun ztrexc (compq n t$ ldt q ldq ifst ilst info)
+ (declare (type (simple-array character (*)) compq)
+ (type (f2cl-lib:integer4) info ilst ifst ldq ldt n)
+ (type (array f2cl-lib:complex16 (*)) q t$))
+ (f2cl-lib:with-multi-array-data
+ ((t$ f2cl-lib:complex16 t$-%data% t$-%offset%)
+ (q f2cl-lib:complex16 q-%data% q-%offset%)
+ (compq character compq-%data% compq-%offset%))
+ (prog
+ ((sn #C(0.0d0 0.0d0)) (t11 #C(0.0d0 0.0d0)) (t22 #C(0.0d0 0.0d0))
+ (temp #C(0.0d0 0.0d0)) (cs 0.0d0) (k 0) (m1 0) (m2 0)
+ (m3 0) (wantq nil)
+ (dconjg$ 0.0))
+ (declare (type (f2cl-lib:complex16) temp t22 t11 sn)
+ (type (double-float) cs)
+ (type (f2cl-lib:integer4) m3 m2 m1 k) (type f2cl-lib:logical wantq)
+ (type (single-float) dconjg$))
+ (setf info 0)
+ (setf wantq
+ (multiple-value-bind (ret-val var-0 var-1) (lsame compq "V")
+ (declare (ignore var-1)) (when var-0 (setf compq var-0)) ret-val))
+ (cond
+ ((and
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame compq "N")
+ (declare (ignore var-1)) (when var-0 (setf compq var-0)) ret-val))
+ (not wantq))
+ (setf info -1))
+ ((< n 0) (setf info -2))
+ ((< ldt (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n)))
+ (setf info -4))
+ ((or (< ldq 1)
+ (and wantq
+ (< ldq (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n)))))
+ (setf info -6))
+ ((or (< ifst 1) (> ifst n)) (setf info -7))
+ ((or (< ilst 1) (> ilst n)) (setf info -8)))
+ (cond ((/= info 0)
+ (xerbla "ZTREXC" (f2cl-lib:int-sub info)) (go end_label)))
+ (if (or (= n 1) (= ifst ilst)) (go end_label))
+ (cond ((< ifst ilst) (setf m1 0) (setf m2 -1) (setf m3 1))
+ (t (setf m1 -1) (setf m2 0) (setf m3 -1)))
+ (f2cl-lib:fdo (k (f2cl-lib:int-add ifst m1) (f2cl-lib:int-add k m3))
+ ((> k
+ (f2cl-lib:int-add ilst m2))
+ nil)
+ (tagbody
+ (setf t11 (f2cl-lib:fref t$-%data% (k k)
+ ((1 ldt) (1 *)) t$-%offset%))
+ (setf t22
+ (f2cl-lib:fref t$-%data%
+ ((f2cl-lib:int-add k 1) (f2cl-lib:int-add k 1))
+ ((1 ldt) (1 *)) t$-%offset%))
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
+ (zlartg
+ (f2cl-lib:fref t$-%data% (k (f2cl-lib:int-add k 1))
+ ((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 (<= (f2cl-lib:int-add k 2) n)
+ (zrot (f2cl-lib:int-sub n k 1)
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16
+ (k (f2cl-lib:int-add k 2)) ((1 ldt) (1 *)) t$-%offset%)
+ ldt
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16
+ ((+ k 1) (f2cl-lib:int-add k 2))
+ ((1 ldt) (1 *)) t$-%offset%)
+ ldt cs sn))
+ (zrot (f2cl-lib:int-sub k 1)
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16 (1 k)
+ ((1 ldt) (1 *))
+ t$-%offset%)
+ 1
+ (f2cl-lib:array-slice t$-%data% f2cl-lib:complex16
+ (1 (f2cl-lib:int-add k 1)) ((1 ldt) (1 *)) t$-%offset%)
+ 1 cs (f2cl-lib:dconjg sn))
+ (setf (f2cl-lib:fref t$-%data% (k k)
+ ((1 ldt) (1 *)) t$-%offset%) t22)
+ (setf
+ (f2cl-lib:fref t$-%data% ((f2cl-lib:int-add k 1)
+ (f2cl-lib:int-add k 1))
+ ((1 ldt) (1 *)) t$-%offset%)
+ t11)
+ (cond
+ (wantq
+ (zrot n
+ (f2cl-lib:array-slice q-%data% f2cl-lib:complex16 (1 k)
+ ((1 ldq) (1 *))
+ q-%offset%)
+ 1
+ (f2cl-lib:array-slice q-%data% f2cl-lib:complex16
+ (1 (f2cl-lib:int-add k 1)) ((1 ldq) (1 *)) q-%offset%)
+ 1 cs (f2cl-lib:dconjg sn))))
+ label10))
+ (go end_label) end_label
+ (return (values compq nil nil nil nil nil nil nil info)))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -119415,7 +132303,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zung2r.f}
* =====================================================================
SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
*
@@ -119505,10 +132393,85 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zung2r}
-
+(let*
+ ((one (coerce (f2cl-lib:cmplx 1.0d0 0.0d0) 'f2cl-lib:complex16))
+ (zero (coerce (f2cl-lib:cmplx 0.0d0 0.0d0) 'f2cl-lib:complex16)))
+ (declare (type (f2cl-lib:complex16) one) (type (f2cl-lib:complex16) zero)
+ (ignorable one zero))
+ (defun zung2r (m n k a lda tau work info)
+ (declare (type (f2cl-lib:integer4) info lda k n m)
+ (type (array f2cl-lib:complex16 (*)) work tau a))
+ (f2cl-lib:with-multi-array-data
+ ((a f2cl-lib:complex16 a-%data% a-%offset%)
+ (tau f2cl-lib:complex16 tau-%data% tau-%offset%)
+ (work f2cl-lib:complex16 work-%data% work-%offset%))
+ (prog ((i 0) (j 0) (l 0))
+ (declare (type (f2cl-lib:integer4) l j i)) (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 f2cl-lib:integer4 1) (the f2cl-lib:integer4 m)))
+ (setf info -5)))
+ (cond ((/= info 0)
+ (xerbla "ZUNG2R" (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)
+ label10))
+ (setf (f2cl-lib:fref a-%data% (j j)
+ ((1 lda) (1 *)) a-%offset%) one) label20)
+ )
+ (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)
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
+ (zlarf "Left" (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1)
+ (f2cl-lib:int-sub n i)
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ (i i) ((1 lda) (1 *))
+ a-%offset%)
+ 1 (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%)
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ (i (f2cl-lib:int-add i 1)) ((1 lda) (1 *)) a-%offset%)
+ lda work)
+ (declare (ignore var-0 var-1 var-2 var-3
+ var-4 var-5 var-6 var-8))
+ (setf lda var-7))))
+ (if (< i m)
+ (zscal (f2cl-lib:int-sub m i)
+ (- (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%))
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ i 1) i)
+ ((1 lda) (1 *)) a-%offset%)
+ 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)
+ label30))
+ label40))
+ (go end_label)
+ end_label (return (values nil nil nil nil lda nil nil info)))
+ )))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -119635,7 +132598,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zunghr.f}
* =====================================================================
SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
*
@@ -119753,10 +132716,140 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zunghr}
-
+(let*
+ ((zero (coerce (f2cl-lib:cmplx 0.0d0 0.0d0) 'f2cl-lib:complex16))
+ (one (coerce (f2cl-lib:cmplx 1.0d0 0.0d0) 'f2cl-lib:complex16)))
+ (declare (type (f2cl-lib:complex16) zero) (type (f2cl-lib:complex16) one)
+ (ignorable zero one))
+ (defun zunghr (n ilo ihi a lda tau work lwork info)
+ (declare (type (f2cl-lib:integer4) info lwork lda ihi ilo n)
+ (type (array f2cl-lib:complex16 (*)) work tau a))
+ (f2cl-lib:with-multi-array-data
+ ((a f2cl-lib:complex16 a-%data% a-%offset%)
+ (tau f2cl-lib:complex16 tau-%data% tau-%offset%)
+ (work f2cl-lib:complex16 work-%data% work-%offset%))
+ (prog
+ ((i 0) (iinfo 0) (j 0) (lwkopt 0) (nb 0) (nh 0) (lquery nil))
+ (declare (type (f2cl-lib:integer4) nh nb lwkopt j iinfo i)
+ (type f2cl-lib:logical lquery))
+ (setf info 0) (setf nh (f2cl-lib:int-sub ihi ilo))
+ (setf lquery (coerce (= lwork -1) 'f2cl-lib:logical))
+ (cond ((< n 0) (setf info -1))
+ ((or (< ilo 1)
+ (> ilo (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n))))
+ (setf info -2))
+ ((or (< ihi (min (the f2cl-lib:integer4 ilo)
+ (the f2cl-lib:integer4 n)))
+ (> ihi n))
+ (setf info -3))
+ ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n)))
+ (setf info -5))
+ ((and (< lwork (max (the f2cl-lib:integer4 1)
+ (the f2cl-lib:integer4 nh)))
+ (not lquery))
+ (setf info -8)))
+ (cond
+ ((= info 0)
+ (setf nb
+ (multiple-value-bind (ret-val var-0 var-1 var-2 var-3
+ var-4 var-5 var-6)
+ (ilaenv 1 "ZUNGQR" " " nh nh nh -1)
+ (declare (ignore var-0 var-1 var-2 var-6))
+ (when var-3 (setf nh var-3))
+ (when var-4 (setf nh var-4))
+ (when var-5 (setf nh var-5)) ret-val))
+ (setf lwkopt
+ (f2cl-lib:int-mul
+ (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nh)) nb))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (coerce lwkopt 'f2cl-lib:complex16))))
+ (cond ((/= info 0)
+ (xerbla "ZUNGHR" (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 1 'f2cl-lib:complex16))
+ (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)
+ label10))
+ (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%))
+ label20))
+ (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)
+ label30))
+ label40))
+ (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)
+ label50))
+ (setf (f2cl-lib:fref a-%data% (j j)
+ ((1 lda) (1 *)) a-%offset%) one) label60)
+ )
+ (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)
+ label70))
+ (setf (f2cl-lib:fref a-%data% (j j)
+ ((1 lda) (1 *)) a-%offset%) one) label80)
+ )
+ (cond
+ ((> nh 0)
+ (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5
+ var-6 var-7 var-8)
+ (zungqr nh nh nh
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ ilo 1) (f2cl-lib:int-add ilo 1)) ((1 lda) (1 *)) a-%offset%)
+ lda
+ (f2cl-lib:array-slice tau-%data% f2cl-lib:complex16 (ilo) ((1 *))
+ tau-%offset%)
+ work lwork iinfo)
+ (declare (ignore var-3 var-5 var-6)) (when var-0 (setf nh var-0))
+ (when var-1 (setf nh var-1)) (when var-2 (setf nh var-2))
+ (when var-4 (setf lda var-4)) (when var-7 (setf lwork var-7))
+ (when var-8 (setf iinfo var-8)))))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (coerce lwkopt 'f2cl-lib:complex16))
+ (go end_label) end_label
+ (return (values nil nil nil nil lda nil nil lwork info))))))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -119885,7 +132978,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zungqr.f}
* =====================================================================
SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
@@ -120050,10 +133143,207 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zungqr}
-
+(let* ((zero (coerce (f2cl-lib:cmplx 0.0d0 0.0d0) 'f2cl-lib:complex16)))
+ (declare (type (f2cl-lib:complex16) zero) (ignorable zero))
+ (defun zungqr (m n k a lda tau work lwork info)
+ (declare (type (f2cl-lib:integer4) info lwork lda k n m)
+ (type (array f2cl-lib:complex16 (*)) work tau a))
+ (f2cl-lib:with-multi-array-data
+ ((a f2cl-lib:complex16 a-%data% a-%offset%)
+ (tau f2cl-lib:complex16 tau-%data% tau-%offset%)
+ (work f2cl-lib:complex16 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 (f2cl-lib:integer4) nx nbmin nb lwkopt ldwork
+ l kk ki j iws iinfo ib i)
+ (type f2cl-lib:logical lquery))
+ (setf info 0)
+ (setf nb
+ (multiple-value-bind (ret-val var-0 var-1 var-2 var-3
+ var-4 var-5 var-6)
+ (ilaenv 1 "ZUNGQR" " " m n k -1)
+ (declare (ignore var-0 var-1 var-2 var-6))
+ (when var-3 (setf m var-3)) (when var-4 (setf n var-4))
+ (when var-5 (setf k var-5)) ret-val))
+ (setf lwkopt
+ (f2cl-lib:int-mul (max (the f2cl-lib:integer4 1)
+ (the f2cl-lib:integer4 n))
+ nb))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (coerce lwkopt 'f2cl-lib:complex16))
+ (setf lquery (coerce (= lwork -1) 'f2cl-lib:logical))
+ (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 f2cl-lib:integer4 1) (the f2cl-lib:integer4 m)))
+ (setf info -5))
+ ((and (< lwork (max (the f2cl-lib:integer4 1)
+ (the f2cl-lib:integer4 n)))
+ (not lquery))
+ (setf info -8)))
+ (cond ((/= info 0)
+ (xerbla "ZUNGQR" (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 1 'f2cl-lib:complex16))
+ (go end_label)))
+ (setf nbmin 2) (setf nx 0) (setf iws n)
+ (cond
+ ((and (> nb 1) (< nb k))
+ (setf nx
+ (max (the f2cl-lib:integer4 0)
+ (the f2cl-lib:integer4
+ (multiple-value-bind (ret-val var-0 var-1 var-2
+ var-3 var-4 var-5 var-6)
+ (ilaenv 3 "ZUNGQR" " " m n k -1)
+ (declare (ignore var-0 var-1 var-2 var-6))
+ (when var-3 (setf m var-3))
+ (when var-4 (setf n var-4))
+ (when var-5 (setf k var-5)) ret-val))))
+ (cond
+ ((< nx k) (setf ldwork n) (setf iws (f2cl-lib:int-mul ldwork nb))
+ (cond
+ ((< lwork iws)
+ (setf nb (the f2cl-lib:integer4 (truncate lwork ldwork)))
+ (setf nbmin
+ (max (the f2cl-lib:integer4 2)
+ (the f2cl-lib:integer4
+ (multiple-value-bind
+ (ret-val var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (ilaenv 2 "ZUNGQR" " " m n k -1)
+ (declare (ignore var-0 var-1 var-2 var-6))
+ (when var-3 (setf m var-3)) (when var-4 (setf n var-4))
+ (when var-5 (setf k var-5)) ret-val))))))))))
+ (cond
+ ((and (>= nb nbmin) (< nb k) (< nx k))
+ (setf ki (* (the f2cl-lib:integer4 (truncate (- k nx 1) nb)) nb))
+ (setf kk
+ (min (the f2cl-lib:integer4 k)
+ (the f2cl-lib:integer4 (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)
+ label10))
+ label20)))
+ (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)
+ (zung2r (f2cl-lib:int-sub m kk) (f2cl-lib:int-sub n kk)
+ (f2cl-lib:int-sub k kk)
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ ((+ kk 1) (f2cl-lib:int-add kk 1)) ((1 lda) (1 *)) a-%offset%)
+ lda
+ (f2cl-lib:array-slice tau-%data% f2cl-lib:complex16
+ ((+ kk 1)) ((1 *))
+ tau-%offset%)
+ work iinfo)
+ (declare (ignore var-0 var-1 var-2 var-3 var-5 var-6))
+ (setf lda var-4)
+ (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 f2cl-lib:integer4 nb)
+ (the f2cl-lib:integer4
+ (f2cl-lib:int-add (f2cl-lib:int-sub k i) 1))))
+ (cond
+ ((<= (f2cl-lib:int-add i ib) n)
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5
+ var-6 var-7 var-8)
+ (zlarft "Forward" "Columnwise"
+ (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) ib
+ (f2cl-lib:array-slice a-%data%
+ f2cl-lib:complex16 (i i) ((1 lda) (1 *))
+ a-%offset%)
+ lda
+ (f2cl-lib:array-slice tau-%data%
+ f2cl-lib:complex16 (i) ((1 *))
+ tau-%offset%)
+ work ldwork)
+ (declare (ignore var-0 var-1 var-2 var-3
+ var-4 var-6 var-7))
+ (setf lda var-5) (setf ldwork var-8))
+ (multiple-value-bind
+ (var-0 var-1 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)
+ (zlarfb "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-%data%
+ f2cl-lib:complex16 (i i) ((1 lda) (1 *))
+ a-%offset%)
+ lda work ldwork
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16
+ (i (f2cl-lib:int-add i ib))
+ ((1 lda) (1 *)) a-%offset%)
+ lda
+ (f2cl-lib:array-slice work-%data%
+ f2cl-lib:complex16 ((+ ib 1)) ((1 *))
+ work-%offset%)
+ ldwork)
+ (declare
+ (ignore var-0 var-1 var-2 var-3 var-4
+ var-5 var-7 var-9 var-11 var-13))
+ (setf ib var-6)
+ (setf lda var-8)
+ (setf ldwork var-10)
+ (setf lda var-12)
+ (setf ldwork var-14))))
+ (multiple-value-bind (var-0 var-1 var-2 var-3
+ var-4 var-5 var-6 var-7)
+ (zung2r (f2cl-lib:int-add
+ (f2cl-lib:int-sub m i) 1) ib ib
+ (f2cl-lib:array-slice a-%data%
+ f2cl-lib:complex16 (i i) ((1 lda) (1 *))
+ a-%offset%)
+ lda
+ (f2cl-lib:array-slice tau-%data%
+ f2cl-lib:complex16 (i) ((1 *))
+ tau-%offset%)
+ work iinfo)
+ (declare (ignore var-0 var-1 var-2
+ var-3 var-5 var-6))
+ (setf lda var-4)
+ (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)
+ label30))
+ label40))
+ label50))))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (coerce iws 'f2cl-lib:complex16))
+ (go end_label)
+ end_label
+ (return (values m n k nil lda nil nil nil info)))
+ )))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -120209,7 +133499,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zunm2r.f}
* =====================================================================
SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
@@ -120340,10 +133630,106 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zunm2r}
-
+(let* ((one (coerce (f2cl-lib:cmplx 1.0d0 0.0d0) 'f2cl-lib:complex16)))
+ (declare (type (f2cl-lib:complex16) one) (ignorable one))
+ (defun zunm2r (side trans m n k a lda tau c ldc work info)
+ (declare (type (simple-array character (*)) trans side)
+ (type (f2cl-lib:integer4) info ldc lda k n m)
+ (type (array f2cl-lib:complex16 (*)) work c tau a))
+ (f2cl-lib:with-multi-array-data
+ ((a f2cl-lib:complex16 a-%data% a-%offset%)
+ (tau f2cl-lib:complex16 tau-%data% tau-%offset%)
+ (c f2cl-lib:complex16 c-%data% c-%offset%)
+ (work f2cl-lib:complex16 work-%data% work-%offset%)
+ (side character side-%data% side-%offset%)
+ (trans character trans-%data% trans-%offset%))
+ (prog
+ ((aii #C(0.0d0 0.0d0))
+ (taui #C(0.0d0 0.0d0)) (i 0) (i1 0) (i2 0) (i3 0)
+ (ic 0) (jc 0) (mi 0) (ni 0) (nq 0) (left nil) (notran nil))
+ (declare (type (f2cl-lib:complex16) taui aii)
+ (type (f2cl-lib:integer4) nq ni mi jc ic i3 i2 i1 i)
+ (type f2cl-lib:logical notran left))
+ (setf info 0)
+ (setf left
+ (multiple-value-bind (ret-val var-0 var-1) (lsame side "L")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val))
+ (setf notran
+ (multiple-value-bind (ret-val var-0 var-1) (lsame trans "N")
+ (declare (ignore var-1)) (when var-0 (setf trans var-0)) ret-val))
+ (cond (left (setf nq m)) (t (setf nq n)))
+ (cond
+ ((and (not left)
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame side "R")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val)))
+ (setf info -1))
+ ((and (not notran)
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame trans "C")
+ (declare (ignore var-1))
+ (when var-0 (setf trans var-0)) ret-val)))
+ (setf info -2))
+ ((< m 0) (setf info -3)) ((< n 0) (setf info -4))
+ ((or (< k 0) (> k nq)) (setf info -5))
+ ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nq)))
+ (setf info -7))
+ ((< ldc (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 m)))
+ (setf info -10)))
+ (cond ((/= info 0)
+ (xerbla "ZUNM2R" (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)))
+ (cond
+ (notran
+ (setf taui
+ (f2cl-lib:fref tau-%data% (i) ((1 *)) tau-%offset%)))
+ (t
+ (setf taui
+ (coerce
+ (f2cl-lib:dconjg (f2cl-lib:fref tau-%data% (i)
+ ((1 *)) tau-%offset%))
+ 'f2cl-lib:complex16))))
+ (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)
+ (multiple-value-bind (var-0 var-1 var-2 var-3
+ var-4 var-5 var-6 var-7 var-8)
+ (zlarf side mi ni
+ (f2cl-lib:array-slice a-%data%
+ f2cl-lib:complex16 (i i) ((1 lda) (1 *))
+ a-%offset%)
+ 1 taui
+ (f2cl-lib:array-slice c-%data%
+ f2cl-lib:complex16 (ic jc) ((1 ldc) (1 *))
+ c-%offset%)
+ ldc work)
+ (declare (ignore var-1 var-2 var-3 var-4 var-5 var-6 var-8))
+ (setf side var-0) (setf ldc var-7))
+ (setf (f2cl-lib:fref a-%data% (i i)
+ ((1 lda) (1 *)) a-%offset%) aii) label10)
+ )
+ (go end_label) end_label
+ (return (values side trans nil nil nil nil nil nil nil ldc nil info)))
+ )))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -120516,7 +133902,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zunmhr.f}
* =====================================================================
SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C,
$ LDC, WORK, LWORK, INFO )
@@ -120636,10 +134022,129 @@ Man Page Details
*
END
-\end{verbatim}
+\end{chunk}
\begin{chunk}{LAPACK zunmhr}
-
+(defun zunmhr (side trans m n ilo ihi a lda tau c ldc work lwork info)
+ (declare (type (simple-array character (*)) trans side)
+ (type (f2cl-lib:integer4) info lwork ldc lda ihi ilo n m)
+ (type (array f2cl-lib:complex16 (*)) work c tau a))
+ (f2cl-lib:with-multi-array-data
+ ((a f2cl-lib:complex16 a-%data% a-%offset%)
+ (tau f2cl-lib:complex16 tau-%data% tau-%offset%)
+ (c f2cl-lib:complex16 c-%data% c-%offset%)
+ (work f2cl-lib:complex16 work-%data% work-%offset%)
+ (side character side-%data% side-%offset%)
+ (trans character trans-%data% trans-%offset%))
+ (prog
+ ((i1 0) (i2 0) (iinfo 0) (lwkopt 0) (mi 0)
+ (nb 0) (nh 0) (ni 0) (nq 0) (nw 0)
+ (left nil) (lquery nil))
+ (declare (type (f2cl-lib:integer4) nw nq ni nh nb mi lwkopt iinfo i2 i1)
+ (type f2cl-lib:logical lquery left))
+ (setf info 0) (setf nh (f2cl-lib:int-sub ihi ilo))
+ (setf left
+ (multiple-value-bind (ret-val var-0 var-1) (lsame side "L")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val))
+ (setf lquery (coerce (= lwork -1) 'f2cl-lib:logical))
+ (cond (left (setf nq m) (setf nw n)) (t (setf nq n) (setf nw m)))
+ (cond
+ ((and (not left)
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame side "R")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val)))
+ (setf info -1))
+ ((and
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame trans "N")
+ (declare (ignore var-1)) (when var-0 (setf trans var-0)) ret-val))
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame trans "C")
+ (declare (ignore var-1)) (when var-0 (setf trans var-0)) ret-val)))
+ (setf info -2))
+ ((< m 0) (setf info -3)) ((< n 0) (setf info -4))
+ ((or (< ilo 1)
+ (> ilo (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nq))))
+ (setf info -5))
+ ((or (< ihi (min (the f2cl-lib:integer4 ilo)
+ (the f2cl-lib:integer4 nq)))
+ (> ihi nq))
+ (setf info -6))
+ ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nq)))
+ (setf info -8))
+ ((< ldc (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 m)))
+ (setf info -11))
+ ((and (< lwork (max (the f2cl-lib:integer4 1)
+ (the f2cl-lib:integer4 nw)))
+ (not lquery))
+ (setf info -13)))
+ (cond
+ ((= info 0)
+ (cond
+ (left
+ (setf nb
+ (multiple-value-bind (ret-val var-0 var-1 var-2
+ var-3 var-4 var-5 var-6)
+ (ilaenv 1 "ZUNMQR" (f2cl-lib:f2cl-// side trans) nh n nh -1)
+ (declare (ignore var-0 var-1 var-2 var-6))
+ (when var-3 (setf nh var-3))
+ (when var-4 (setf n var-4))
+ (when var-5 (setf nh var-5)) ret-val)))
+ (t
+ (setf nb
+ (multiple-value-bind (ret-val var-0 var-1 var-2 var-3
+ var-4 var-5 var-6)
+ (ilaenv 1 "ZUNMQR" (f2cl-lib:f2cl-// side trans) m nh nh -1)
+ (declare (ignore var-0 var-1 var-2 var-6))
+ (when var-3 (setf m var-3))
+ (when var-4 (setf nh var-4))
+ (when var-5 (setf nh var-5)) ret-val))))
+ (setf lwkopt
+ (f2cl-lib:int-mul
+ (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nw)) nb))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (coerce lwkopt 'f2cl-lib:complex16))))
+ (cond ((/= info 0)
+ (xerbla "ZUNMHR" (f2cl-lib:int-sub info)) (go end_label))
+ (lquery (go end_label)))
+ (cond
+ ((or (= m 0) (= n 0) (= nh 0))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (coerce 1 'f2cl-lib:complex16))
+ (go end_label)))
+ (cond
+ (left (setf mi nh) (setf ni n) (setf i1 (f2cl-lib:int-add ilo 1))
+ (setf i2 1))
+ (t (setf mi m)
+ (setf ni nh)
+ (setf i1 1)
+ (setf i2 (f2cl-lib:int-add ilo 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)
+ (zunmqr side trans mi ni nh
+ (f2cl-lib:array-slice a-%data% f2cl-lib:complex16 ((+ ilo 1) ilo)
+ ((1 lda) (1 *)) a-%offset%)
+ lda
+ (f2cl-lib:array-slice tau-%data% f2cl-lib:complex16 (ilo) ((1 *))
+ tau-%offset%)
+ (f2cl-lib:array-slice c-%data%
+ f2cl-lib:complex16 (i1 i2) ((1 ldc) (1 *))
+ c-%offset%)
+ ldc work lwork iinfo)
+ (declare (ignore var-5 var-7 var-8 var-10))
+ (when var-0 (setf side var-0))
+ (when var-1 (setf trans var-1)) (when var-2 (setf mi var-2))
+ (when var-3 (setf ni var-3)) (when var-4 (setf nh var-4))
+ (when var-6 (setf lda var-6)) (when var-9 (setf ldc var-9))
+ (when var-11 (setf lwork var-11)) (when var-12 (setf iinfo var-12)))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (coerce lwkopt 'f2cl-lib:complex16))
+ (go end_label) end_label
+ (return
+ (values side trans m n nil nil nil lda nil nil ldc nil lwork info)))
+ ))
\end{chunk}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -120805,7 +134310,7 @@ Man Page Details
\end{chunk}
-\begin{verbatim}
+\begin{chunk}{zunmqr.f}
* =====================================================================
SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, LWORK, INFO )
@@ -120987,10 +134492,199 @@ Man Page Details
*
END
+\end{chunk}
+
+\begin{verbatim}
+Warning: Types of argument 0 in call to ZUNM2R do not match.
+ Declared type: (SIMPLE-ARRAY CHARACTER (*))
+ Argument type: (STRING 1)
+Warning: Types of argument 1 in call to ZUNM2R do not match.
+ Declared type: (SIMPLE-ARRAY CHARACTER (*))
+ Argument type: (STRING 1)
+Warning: Types of argument 0 in call to ZLARFB do not match.
+ Declared type: (SIMPLE-ARRAY CHARACTER (*))
+ Argument type: (STRING 1)
+Warning: Types of argument 1 in call to ZLARFB do not match.
+ Declared type: (SIMPLE-ARRAY CHARACTER (*))
+ Argument type: (STRING 1)
\end{verbatim}
\begin{chunk}{LAPACK zunmqr}
-
+(let* ((nbmax 64) (ldt (+ nbmax 1)))
+ (declare (type (f2cl-lib:integer4 64 64) nbmax) (type (f2cl-lib:integer4) ldt)
+ (ignorable nbmax ldt))
+ (defun zunmqr (side trans m n k a lda tau c ldc work lwork info)
+ (declare (type (simple-array character (*)) trans side)
+ (type (f2cl-lib:integer4) info lwork ldc lda k n m)
+ (type (array f2cl-lib:complex16 (*)) work c tau a))
+ (f2cl-lib:with-multi-array-data
+ ((a f2cl-lib:complex16 a-%data% a-%offset%)
+ (tau f2cl-lib:complex16 tau-%data% tau-%offset%)
+ (c f2cl-lib:complex16 c-%data% c-%offset%)
+ (work f2cl-lib:complex16 work-%data% work-%offset%)
+ (side character side-%data% side-%offset%)
+ (trans character trans-%data% trans-%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
+ 'f2cl-lib:complex16)))
+ (declare
+ (type (f2cl-lib:integer4) nw nq ni nbmin nb mi
+ lwkopt ldwork jc iws iinfo ic
+ ib i3 i2 i1 i)
+ (type f2cl-lib:logical notran lquery left)
+ (type (array f2cl-lib:complex16 (*)) t$))
+ (setf info 0)
+ (setf left
+ (multiple-value-bind (ret-val var-0 var-1) (lsame side "L")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val))
+ (setf notran
+ (multiple-value-bind (ret-val var-0 var-1) (lsame trans "N")
+ (declare (ignore var-1)) (when var-0 (setf trans var-0)) ret-val))
+ (setf lquery (coerce (= lwork -1) 'f2cl-lib:logical))
+ (cond (left (setf nq m) (setf nw n)) (t (setf nq n) (setf nw m)))
+ (cond
+ ((and (not left)
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame side "R")
+ (declare (ignore var-1)) (when var-0 (setf side var-0)) ret-val)))
+ (setf info -1))
+ ((and (not notran)
+ (not
+ (multiple-value-bind (ret-val var-0 var-1) (lsame trans "C")
+ (declare (ignore var-1))
+ (when var-0 (setf trans var-0)) ret-val)))
+ (setf info -2))
+ ((< m 0) (setf info -3)) ((< n 0) (setf info -4))
+ ((or (< k 0) (> k nq)) (setf info -5))
+ ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nq)))
+ (setf info -7))
+ ((< ldc (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 m)))
+ (setf info -10))
+ ((and (< lwork (max (the f2cl-lib:integer4 1)
+ (the f2cl-lib:integer4 nw)))
+ (not lquery))
+ (setf info -12)))
+ (cond
+ ((= info 0)
+ (setf nb
+ (min (the f2cl-lib:integer4 nbmax)
+ (the f2cl-lib:integer4
+ (multiple-value-bind (ret-val var-0 var-1 var-2
+ var-3 var-4 var-5 var-6)
+ (ilaenv 1 "ZUNMQR" (f2cl-lib:f2cl-// side trans) m n k -1)
+ (declare (ignore var-0 var-1 var-2 var-6))
+ (when var-3 (setf m var-3))
+ (when var-4 (setf n var-4))
+ (when var-5 (setf k var-5)) ret-val))))
+ (setf lwkopt
+ (f2cl-lib:int-mul
+ (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nw)) nb))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (coerce lwkopt 'f2cl-lib:complex16))))
+ (cond ((/= info 0)
+ (xerbla "ZUNMQR" (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 1 'f2cl-lib:complex16))
+ (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 f2cl-lib:integer4 (truncate lwork ldwork)))
+ (setf nbmin
+ (max (the f2cl-lib:integer4 2)
+ (the f2cl-lib:integer4
+ (multiple-value-bind
+ (ret-val var-0 var-1 var-2 var-3 var-4 var-5 var-6)
+ (ilaenv 2 "ZUNMQR" (f2cl-lib:f2cl-// side trans) m n k -1)
+ (declare (ignore var-0 var-1 var-2 var-6))
+ (when var-3 (setf m var-3))
+ (when var-4 (setf n var-4))
+ (when var-5 (setf k var-5)) ret-val)))))))
+ (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)
+ (zunm2r side trans m n k a lda tau c ldc work iinfo)
+ (declare (ignore var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-10))
+ (setf side var-0)
+ (setf trans var-1)
+ (setf ldc var-9)
+ (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 f2cl-lib:integer4 (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 f2cl-lib:integer4 nb)
+ (the f2cl-lib:integer4 (f2cl-lib:int-add
+ (f2cl-lib:int-sub k i) 1))))
+ (multiple-value-bind
+ (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
+ (zlarft "Forward" "Columnwise"
+ (f2cl-lib:int-add (f2cl-lib:int-sub nq i) 1) ib
+ (f2cl-lib:array-slice a-%data%
+ f2cl-lib:complex16 (i i) ((1 lda) (1 *))
+ a-%offset%)
+ lda
+ (f2cl-lib:array-slice tau-%data%
+ f2cl-lib:complex16 (i) ((1 *))
+ tau-%offset%)
+ t$ ldt)
+ (declare (ignore var-0 var-1 var-2 var-3
+ var-4 var-6 var-7))
+ (setf lda var-5) (setf ldt var-8))
+ (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)))
+ (multiple-value-bind
+ (var-0 var-1 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)
+ (zlarfb side trans "Forward" "Columnwise" mi ni ib
+ (f2cl-lib:array-slice a-%data%
+ f2cl-lib:complex16 (i i) ((1 lda) (1 *))
+ a-%offset%)
+ lda t$ ldt
+ (f2cl-lib:array-slice c-%data%
+ f2cl-lib:complex16 (ic jc) ((1 ldc) (1 *))
+ c-%offset%)
+ ldc work ldwork)
+ (declare (ignore var-2 var-3 var-4 var-5
+ var-7 var-9 var-11 var-13))
+ (setf side var-0)
+ (setf trans var-1)
+ (setf ib var-6)
+ (setf lda var-8)
+ (setf ldt var-10)
+ (setf ldc var-12)
+ (setf ldwork var-14))
+ label10))))
+ (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
+ (coerce lwkopt 'f2cl-lib:complex16))
+ (go end_label) end_label
+ (return
+ (values side trans m n k nil lda nil nil ldc nil nil info))))))
\end{chunk}
@@ -121722,10 +135416,225 @@ Man Page Details
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Chunk collections}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\begin{chunk}{BLAS FORTRAN}
+\begin{chunk}{dcabs1.f}
+\begin{chunk}{lsame.f}
+\begin{chunk}{xerbla.f}
+\begin{chunk}{dasum.f}
+\begin{chunk}{daxpy.f}
+\begin{chunk}{dcopy.f}
+\begin{chunk}{ddot.f}
+\begin{chunk}{dnrm2.f}
+\begin{chunk}{drotg.f}
+\begin{chunk}{drot.f}
+\begin{chunk}{dscal.f}
+\begin{chunk}{dswap.f}
+\begin{chunk}{dzasum.f}
+\begin{chunk}{dznrm2.f}
+\begin{chunk}{icamax.f}
+\begin{chunk}{idamax.f}
+\begin{chunk}{isamax.f}
+\begin{chunk}{izamax.f}
+\begin{chunk}{zaxpy.f}
+\begin{chunk}{zcopy.f}
+\begin{chunk}{zdotc.f}
+\begin{chunk}{zdotu.f}
+\begin{chunk}{zdscal.f}
+\begin{chunk}{zrotg.f}
+\begin{chunk}{zscal.f}
+\begin{chunk}{zswap.f}
+\begin{chunk}{dgbmv.f}
+\begin{chunk}{dgemv.f}
+\begin{chunk}{dger.f}
+\begin{chunk}{dsbmv.f}
+\begin{chunk}{dspmv.f}
+\begin{chunk}{dspr2.f}
+\begin{chunk}{dspr.f}
+\begin{chunk}{dsymv.f}
+\begin{chunk}{dsyr2.f}
+\begin{chunk}{dsyr.f}
+\begin{chunk}{dtbmv.f}
+\begin{chunk}{dtbsv.f}
+\begin{chunk}{dtpmv.f}
+\begin{chunk}{dtpsv.f}
+\begin{chunk}{dtrmv.f}
+\begin{chunk}{dtrsv.f}
+\begin{chunk}{zgbmv.f}
+\begin{chunk}{zgemv.f}
+\begin{chunk}{zgerc.f}
+\begin{chunk}{zgeru.f}
+\begin{chunk}{zhbmv.f}
+\begin{chunk}{zhemv.f}
+\begin{chunk}{zher2.f}
+\begin{chunk}{zher.f}
+\begin{chunk}{zhpmv.f}
+\begin{chunk}{zhpr2.f}
+\begin{chunk}{zhpr.f}
+\begin{chunk}{ztbmv.f}
+\begin{chunk}{ztbsv.f}
+\begin{chunk}{ztpmv.f}
+\begin{chunk}{ztpsv.f}
+\begin{chunk}{ztrmv.f}
+\begin{chunk}{ztrsv.f}
+\begin{chunk}{dgemm.f}
+\begin{chunk}{dsymm.f}
+\begin{chunk}{dsyr2k.f}
+\begin{chunk}{dsyrk.f}
+\begin{chunk}{dtrmm.f}
+\begin{chunk}{dtrsm.f}
+\begin{chunk}{zgemm.f}
+\begin{chunk}{zhemm.f}
+\begin{chunk}{zher2k.f}
+\begin{chunk}{zherk.f}
+\begin{chunk}{zsymm.f}
+\begin{chunk}{zsyr2k.f}
+\begin{chunk}{zsyrk.f}
+\begin{chunk}{ztrmm.f}
+\begin{chunk}{ztrsm.f}
+\end{chunk}
+
+\begin{chunk}{LAPACK FORTRAN}
+\begin{chunk}{dbdsdc.f}
+\begin{chunk}{dbdsqr.f}
+\begin{chunk}{ddisna.f}
+\begin{chunk}{dgebak.f}
+\begin{chunk}{dgebal.f}
+\begin{chunk}{dgebd2.f}
+\begin{chunk}{dgebrd.f}
+\begin{chunk}{dgeev.f}
+\begin{chunk}{dgeevx.f}
+\begin{chunk}{dgehd2.f}
+\begin{chunk}{dgehrd.f}
+\begin{chunk}{dgelq2.f}
+\begin{chunk}{dgelqf.f}
+\begin{chunk}{dgeqr2.f}
+\begin{chunk}{dgeqrf.f}
+\begin{chunk}{dgesdd.f}
+\begin{chunk}{dgesvd.f}
+\begin{chunk}{dgesv.f}
+\begin{chunk}{dgetf2.f}
+\begin{chunk}{dgetrf.f}
+\begin{chunk}{dgetrs.f}
+\begin{chunk}{dhseqr.f}
+\begin{chunk}{disnan.f}
+\begin{chunk}{dlabad.f}
+\begin{chunk}{dlabrd.f}
+\begin{chunk}{dlacon.f}
+\begin{chunk}{dlacpy.f}
+\begin{chunk}{dladiv.f}
+\begin{chunk}{dlaed6.f}
+\begin{chunk}{dlaexc.f}
+\begin{chunk}{dlahqr.f}
+\begin{chunk}{dlahrd.f}
+\begin{chunk}{dlaisnan.f}
+\begin{chunk}{dlaln2.f}
+\begin{chunk}{dlamch.f}
+\begin{chunk}{dlamc1.f}
+\begin{chunk}{dlamc2.f}
+\begin{chunk}{dlamc3.f}
+\begin{chunk}{dlamc4.f}
+\begin{chunk}{dlamc5.f}
+\begin{chunk}{dlamrg.f}
+\begin{chunk}{dlange.f}
+\begin{chunk}{dlanhs.f}
+\begin{chunk}{dlanst.f}
+\begin{chunk}{dlanv2.f}
+\begin{chunk}{dlapy2.f}
+\begin{chunk}{dlapy3.f}
+\begin{chunk}{dlaqtr.f}
+\begin{chunk}{dlarfb.f}
+\begin{chunk}{dlarfg.f}
+\begin{chunk}{dlarf.f}
+\begin{chunk}{dlarft.f}
+\begin{chunk}{dlarfx.f}
+\begin{chunk}{dlartg.f}
+\begin{chunk}{dlas2.f}
+\begin{chunk}{dlascl.f}
+\begin{chunk}{dlasd0.f}
+\begin{chunk}{dlasd1.f}
+\begin{chunk}{dlasd2.f}
+\begin{chunk}{dlasd3.f}
+\begin{chunk}{dlasd4.f}
+\begin{chunk}{dlasd5.f}
+\begin{chunk}{dlasd6.f}
+\begin{chunk}{dlasd7.f}
+\begin{chunk}{dlasd8.f}
+\begin{chunk}{dlasda.f}
+\begin{chunk}{dlasdq.f}
+\begin{chunk}{dlasdt.f}
+\begin{chunk}{dlaset.f}
+\begin{chunk}{dlasq1.f}
+\begin{chunk}{dlasq2.f}
+\begin{chunk}{dlasq3.f}
+\begin{chunk}{dlasq4.f}
+\begin{chunk}{dlasq5.f}
+\begin{chunk}{dlasq6.f}
+\begin{chunk}{dlasr.f}
+\begin{chunk}{dlasrt.f}
+\begin{chunk}{dlassq.f}
+\begin{chunk}{dlasv2.f}
+\begin{chunk}{dlaswp.f}
+\begin{chunk}{dlasy2.f}
+\begin{chunk}{dorg2r.f}
+\begin{chunk}{dorgbr.f}
+\begin{chunk}{dorghr.f}
+\begin{chunk}{dorgl2.f}
+\begin{chunk}{dorglq.f}
+\begin{chunk}{dorgqr.f}
+\begin{chunk}{dorm2r.f}
+\begin{chunk}{dormbr.f}
+\begin{chunk}{dorml2.f}
+\begin{chunk}{dormlq.f}
+\begin{chunk}{dormqr.f}
+\begin{chunk}{dtrevc.f}
+\begin{chunk}{dtrexc.f}
+\begin{chunk}{dtrsna.f}
+\begin{chunk}{ieeeck.f}
+\begin{chunk}{ilaenv.f}
+\begin{chunk}{ilazlc.f}
+\begin{chunk}{ilazlr.f}
+\begin{chunk}{zgebak.f}
+\begin{chunk}{zgebal.f}
+\begin{chunk}{zgeev.f}
+\begin{chunk}{zgehd2.f}
+\begin{chunk}{zgehrd.f}
+\begin{chunk}{zhseqr.f}
+\begin{chunk}{zlacgv.f}
+\begin{chunk}{zlacpy.f}
+\begin{chunk}{zladiv.f}
+\begin{chunk}{zlahqr.f}
+\begin{chunk}{zlahr2.f}
+\begin{chunk}{zlange.f}
+\begin{chunk}{zlaqr0.f}
+\begin{chunk}{zlaqr1.f}
+\begin{chunk}{zlaqr2.f}
+\begin{chunk}{zlaqr3.f}
+\begin{chunk}{zlaqr4.f}
+\begin{chunk}{zlaqr5.f}
+\begin{chunk}{zlarfb.f}
+\begin{chunk}{zlarf.f}
+\begin{chunk}{zlzrfg.f}
+\begin{chunk}{zlarft.f}
+\begin{chunk}{zlartg.f}
+\begin{chunk}{zlascl.f}
+\begin{chunk}{zlaset.f}
+\begin{chunk}{zlassq.f}
+\begin{chunk}{zlatrs.f}
+\begin{chunk}{zrot.f}
+\begin{chunk}{ztrevc.f}
+\begin{chunk}{ztrexc.f}
+\begin{chunk}{zung2r.f}
+\begin{chunk}{zunghr.f}
+\begin{chunk}{zungqr.f}
+\begin{chunk}{zunm2r.f}
+\begin{chunk}{zunmhr.f}
+\begin{chunk}{zunmqr.f}
+\end{chunk}
+
\begin{chunk}{Numerics}
(in-package "BOOT")
-\getchunk{BLAS dcabs1}
+\getchunk{BLAS 1 dcabs1}
\getchunk{BLAS 1 dasum}
\getchunk{BLAS 1 daxpy}
\getchunk{BLAS 1 dcopy}
diff --git a/changelog b/changelog
index 3768e51..b27312b 100644
--- a/changelog
+++ b/changelog
@@ -1,3 +1,5 @@
+20120423 tpd src/axiom-website/patches.html 20120423.01.tpd.patch
+20120423 tpd books/bookvol10.5 add missing lapack routines
20120422 tpd src/axiom-website/patches.html 20120422.01.tpd.patch
20120422 tpd books/bookvolbib.bib add LAPACK bibtex reference
20120422 tpd books/bookvol10.5 add LAPACK reference code
diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html
index 4cc46c9..7c28148 100644
--- a/src/axiom-website/patches.html
+++ b/src/axiom-website/patches.html
@@ -3886,5 +3886,7 @@ src/axiom-website/download.html update download list
src/input/cohen.input Joel Cohen algebra example
20120422.01.tpd.patch
books/bookvol10.5 add LAPACK reference code
+20120423.01.tpd.patch
+books/bookvol10.5 add missing lapack routines