diff --git a/books/bookvol10.5.pamphlet b/books/bookvol10.5.pamphlet index c3e9aa4..8e0576c 100644 --- a/books/bookvol10.5.pamphlet +++ b/books/bookvol10.5.pamphlet @@ -14,6 +14,15 @@ \label{#2}% \index{{#1}}% \index{{#2}}}% + +%% +%% calls marks a call from this function to another +%% +\newcommand{\calls}[2]{% e.g. \calls{thisfunc}{thatfunc} +[#2 p\pageref{#2}]\\% +\index{#2!{calledby #1}}% +\index{#1!{calls #2}}}% + %% %% pagepic adds an image and an index entry %% @@ -302,7 +311,7 @@ For complex symmetric matrices, TRANSx=H is not allowed. \chapter{Algebra Cover Code} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{package BLAS1 BlasLevelOne} -\pagehead{BlasLevelOne}{BLAS1} +%\pagehead{BlasLevelOne}{BLAS1} %\pagepic{ps/v104blaslevelone.ps}{BLAS1}{1.00} {\bf Exports:}\\ @@ -312,1597 +321,156 @@ For complex symmetric matrices, TRANSx=H is not allowed. <>= )abbrev package BLAS1 BlasLevelOne -++ Author: Gregory Vanuxem -++ Date Created: 2006 -++ Date Last Updated: Aug 14, 2006 -++ Basic Operations: -++ Related Domains: Vector -++ Also See: -++ AMS Classifications: -++ Keywords: -++ Examples: -++ References: +++ Author: Timothy Daly +++ Date Created: 2010 +++ Date March 24, 2010 ++ Description: ++ This package provides an interface to the Blas library (level 1) --- TODO : dimension of vector and not length -BlasLevelOne(V) : Exports == Implementation where +BlasLevelOne() : Exports == Implementation where SI ==> SingleInteger - R ==> DoubleFloat + DF ==> DoubleFloat V : OneDimensionalArrayAggregate(R) with contiguousStorage + CDF ==> Complex DoubleFloat Exports == with - dot: (SI,V,SI,V,SI) -> R - ++ dot(n,x,incx,y,incy) computes the dot product of two vectors, x and y. - ++ Parameters: - ++ \begin{items} - ++ \item {n}: order of vectors x and y; - ++ \item {x}: the first vector, \#x must be at least (1+(n-1)*abs(incx)); - ++ \item {incx}: increment for the elements of x; - ++ \item {y}: the second vector, \#y must be at least - ++ (1+(n-1)*abs(incy)); - ++ \item {incy}: increment for the elements of y. - ++ \end{items} - - dot: (V,V) -> R - ++ dot(x,y) computes the dot product of two vectors, x and y. - ++ If x and y are not of the same length, it is assumed that they both - ++ have the same length (the smaller). - - nrm2: (SI,V,SI) -> R - ++ nrm2(n,x,incx) computes the euclidean norm of the vector x. - ++ Parameters: - ++ \begin{items} - ++ \item {n}: order of the vector x; - ++ \item {x}: the vector, \#x must be at least (1+(n-1)*abs(incx)); - ++ \item {incx}: Increment for the elements of x. - ++ \end{items} - - nrm2: (V) -> R - ++ nrm2(x) computes the euclidean norm of the vector x. - - asum: (SI,V,SI) -> R - ++ asum(n,x,incx) computes the sum of the absolute values of the vector - ++ elements of x. Parameters: - ++ \begin{items} - ++ \item {n}: order of the vector x; - ++ \item {x}: the vector, \#x must be at least (1+(n-1)*abs(incx)); - ++ \item {incx}: Increment for the elements of x. - ++ \end{items} - - asum: (V) -> R - ++ asum(x) computes the sum of the absolute values of the vector - ++ elements of x. - - iamax: (SI,V,SI) -> SI - ++ iamax(n,x,incx) finds the index of element of a vector that has - ++ the largest absolute value. Parameters: - ++ \begin{items} - ++ \item {n}: order of the vector x; - ++ \item {x}: the vector, \#x must be at least (1+(n-1)*abs(incx)); - ++ \item {incx}: Increment for the elements of x. - ++ \end{items} - - iamax: (V) -> SI - ++ iamax(x) finds the index of element of a vector that has - ++ the largest absolute value. - - swap: (SI,V,SI,V,SI) -> Void - ++ swap(n,x,incx,y,incy) interchanges two vectors, x and y. - ++ Parameters: - ++ \begin{items} - ++ \item {n}: order of vectors x and y; - ++ \item {x}: the first vector, \#x must be at least (1+(n-1)*abs(incx)); - ++ \item {incx}: increment for the elements of x; - ++ \item {y}: the second vector, \#y must be at least - ++ (1+(n-1)*abs(incy)); - ++ \item {incy}: increment for the elements of y. - ++ \end{items} - - swap: (V,V) -> Void - ++ swap(x,y) interchanges two vectors, x and y. - ++ If x and y are not of the same length, it is assumed that they both - ++ have the same length (the smaller). - - copy: (SI,V,SI,V,SI) -> Void - ++ copy(n,x,incx,y,incy) copies a vector, x, to a vector, y. - ++ Parameters: - ++ \begin{items} - ++ \item {n}: order of vectors x and y; - ++ \item {x}: the first vector, \#x must be at least (1+(n-1)*abs(incx)); - ++ \item {incx}: increment for the elements of x; - ++ \item {y}: the second vector, \#y must be at least - ++ (1+(n-1)*abs(incy)); - ++ \item {incy}: increment for the elements of y. - ++ \end{items} - - copy: (V,V) -> Void - ++ copy(x,y) copies a vector, x, to a vector, y. - ++ If x and y are not of the same length, it is assumed that they both - ++ have the same length (the smaller). - - axpy: (SI,R,V,SI,V,SI) -> Void - ++ axpy(n,alpha,x,incx,y,incy) computes the product of a scalar, alpha, - ++ with a vector, x, plus a vector, y. - ++ Parameters: - ++ \begin{items} - ++ \item {n}: order of vectors x and y; - ++ \item {alpha}: a scalar; - ++ \item {x}: the first vector, \#x must be at least (1+(n-1)*abs(incx)); - ++ \item {incx}: increment for the elements of x; - ++ \item {y}: the second vector, \#y must be at least - ++ (1+(n-1)*abs(incy)); - ++ \item {incy}: increment for the elements of y. - ++ \end{items} - - axpy: (R,V,V) -> Void - ++ axpy(alpha,x,y) computes the product of a scalar, alpha, - ++ with a vector, x, plus a vector, y. - ++ If x and y are not of the same length, it is assumed that they both - ++ have the same length (the smaller). - - rot: (SI,V,SI,V,SI,R,R) -> Void - ++ rot(n,x,incx,y,incy,c,s) applies a plane rotation: - ++ x(i) = c*x(i) + s*y(i) - ++ y(i) = c*y(i) - s*x(i) - ++ Parameters: - ++ \begin{items} - ++ \item {n}: order of vectors x and y; - ++ \item {x}: the first vector, \#x must be at least (1+(n-1)*abs(incx)); - ++ \item {incx}: increment for the elements of x; - ++ \item {y}: the second vector, \#y must be at least - ++ (1+(n-1)*abs(incy)); - ++ \item {incy}: increment for the elements of y; - ++ \item {c}: a scalar; - ++ \item {s}: a scalar. - ++ \end{items} - - rot: (V,V,R,R) -> Void - ++ rot(x,y,c,s) applies a plane rotation: - ++ x(i) = c*x(i) + s*y(i) - ++ y(i) = c*y(i) - s*x(i) - ++ If x and y are not of the same length, it is assumed that they both - ++ have the same length (the smaller). - - scal: (SI,R,V,SI) -> Void - ++ scal(n,alpha,x,incx) scales a vector, x, by a scalar, alpha. - ++ Parameters: - ++ \begin{items} - ++ \item {n}: order of the vector x; - ++ \item {alpha}: a scalar; - ++ \item {x}: the vector, \#x must be at least (1+(n-1)*abs(incx)); - ++ \item {incx}: Increment for the elements of x. - ++ \end{items} - - scal: (R,V) -> Void - ++ scal(alpha,x) scales a vector, x, by a scalar, alpha. + dcabs1: CDF -> DF + ++ dcabs1(z) computes (+ (abs (realpart z)) (abs (imagpart z))) Implementation == add - dot(n:SI,x:V,incx:SI,y:V,incy:SI): R == - DDOT(n,x,incx,y,incy)$Lisp - - dot(x:V,y:V): R == - n := min(#x,#y)::SI - DDOT(n,x,1$SI,y,1$SI)$Lisp - - nrm2(n:SI,x:V,incx:SI): R == - DNRM2(n,x,incx)$Lisp - - nrm2(x:V): R == - DNRM2(#x::SI,x,1$SI)$Lisp - - asum(n:SI,x:V,incx:SI): R == - DASUM(n,x,incx)$Lisp - - asum(x:V): R == - DASUM(#x::SI,x,1$SI)$Lisp - - iamax(n:SI,x:V,incx:SI): SI == - IDAMAX(n,x,incx)$Lisp - - iamax(x:V): SI == - IDAMAX(#x::SI,x,1$SI)$Lisp - - swap(n:SI,x:V,incx:SI,y:V,incy:SI): Void == - DSWAP(n,x,incx,y,incy)$Lisp - - swap(x:V,y:V): Void == - n := min(#x,#y)::SI - DSWAP(n,x,1$SI,y,1$SI)$Lisp - - copy(n:SI,x:V,incx:SI,y:V,incy:SI): Void == - DCOPY(n,x,incx,y,incy)$Lisp - - copy(x:V,y:V): Void == - n := min(#x,#y)::SI - DCOPY(n,x,1$SI,y,1$SI)$Lisp - - axpy(n:SI,alpha:R,x:V,incx:SI,y:V,incy:SI): Void == - DAXPY(n,alpha,x,incx,y,incy)$Lisp - - axpy(alpha:R,x:V,y:V): Void == - n := min(#x,#y)::SI - DAXPY(n,alpha,x,1$SI,y,1$SI)$Lisp - - rot(n:SI,x:V,incx:SI,y:V,incy:SI,c:R,s:R): Void == - DROT(n,x,incx,y,incy,c,s)$Lisp - - rot(x:V,y:V,c:R,s:R): Void == - n := min(#x,#y)::SI - DROT(n,x,1$SI,y,1$SI,c,s)$Lisp - - scal(n:SI,alpha:R,x:V,incx:SI): Void == - DSCAL(n,alpha,x,incx)$Lisp + dcabs1(z:CDF):DF == DCABS1(z)$Lisp - scal(alpha:R,x:V): Void == - DSCAL(#x::SI,alpha,x,1$SI)$Lisp @ <>= -"BLAS1" [color="#FF4488",href="bookvol10.4.pdf#nameddest=BLAS1"] -"FS" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FS"] -"ACF" [color="#4488FF",href="bookvol10.2.pdf#nameddest=ACF"] -"BLAS1" -> "FS" -"BLAS1" -> "ACF" +"BLAS1" [color="#FF4488",href="bookvol10.5.pdf#nameddest=BLAS1"] +"FIELD" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FIELD"] +"RADCAT" [color="#4488FF",href="bookvol10.2.pdf#nameddest=RADCAT"] +"BLAS1" -> "FIELD" +"BLAS1" -> "RADCAT" @ - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{package BLAS2 BlasLevelTwo} -\pagehead{BlasLevelTwo}{BLAS2} -%\pagepic{ps/v104blasleveltwo.ps}{BLAS2}{1.00} - -{\bf Exports:}\\ -\begin{tabular}{lllll} -\cross{BLAS2}{?**?} & -\end{tabular} - -<>= -)abbrev package BLAS2 BlasLevelTwo -++ Author: Gregory Vanuxem -++ Date Created: 2006 -++ Date Last Updated: Aug 29, 2006 -++ Basic Operations: -++ Related Domains: ColumnMajorTwoDimensionnalArray, Vector -++ Also See: -++ AMS Classifications: -++ Keywords: -++ Examples: -++ References: -++ Description: -++ This package provides an interface to the -++ Blas library (level 2) -BlasLevelTwo(Row,Col,M,V) : Exports == Implementation where - - R ==> DoubleFloat - SI ==> SingleInteger - CHAR ==> Character - V : OneDimensionalArrayAggregate(R) with contiguousStorage - Row : OneDimensionalArrayAggregate(R) with contiguousStorage - Col : OneDimensionalArrayAggregate(R) with contiguousStorage - M : ColumnMajorTwoDimensionalArrayCategory(R,Row,Col) - - Exports == with - - gemv: (CHAR,SI,SI,R,M,SI,V,SI,R,V,SI) -> Void - ++ gemv(trans,m,n,alpha,A,lda,x,incx,beta,y,incy) performs one of - ++ the matrix-vector operations - ++ y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, - ++ where alpha and beta are scalars, x and y are vectors and A is an - ++ m by n matrix. - ++ Parameters: - ++ \begin{items} - ++ \item {trans}: on entry, specifies the operation to be performed as - ++ follows: - ++ trans = 'N' or 'n' y := alpha*A*x + beta*y. - ++ trans = 'T' or 't' y := alpha*A'*x + beta*y. - ++ Unchanged on exit. - ++ \item {m}: on entry, specifies the number of rows of the matrix A. - ++ m must be at least zero. Unchanged on exit. - ++ \item {n}: on entry, specifies the number of columns of the matrix A. - ++ n must be at least zero. Unchanged on exit. - ++ \item {alpha}: on entry, specifies the scalar alpha. - ++ Unchanged on exit. - ++ \item {A}: before entry, the leading m by n part of the array A must - ++ contain the matrix of coefficients. Unchanged on exit. - ++ \item {lda}: on entry, specifies the first dimension of A as declared - ++ in the calling (sub) program. lda must be at least max( 1, m ). - ++ Unchanged on exit. - ++ \item {x}: array of dimension at least ( 1 + ( n - 1 )*abs( incx ) ) - ++ when trans = 'N' or 'n' - ++ and at least ( 1 + ( m - 1 )*abs( incx ) ) otherwise. Before entry, - ++ the incremented array x must contain the - ++ vector x. Unchanged on exit. - ++ \item {incx}: increment for the elements of x. - ++ \item {beta}: on entry, beta specifies the scalar beta. When beta is - ++ supplied as zero then y need not be set on input. Unchanged on exit. - ++ \item {y}: array of dimension at least ( 1 + ( m - 1 )*abs( incy ) ) - ++ when trans = 'N' or 'n' - ++ and at least ( 1 + ( n - 1 )*abs( incy ) ) otherwise. - ++ Before entry with beta non-zero, - ++ the incremented array y must contain the vector y. On exit, - ++ y is overwritten by the updated vector y. - ++ \item {incy}: increment for the elements of y. - ++ \end{items} - - gemv: (CHAR,R,M,V,R,V) -> Void - ++ gemv(trans,alpha,A,x,beta,y) performs one of - ++ the matrix-vector operations - ++ y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, - ++ where alpha and beta are scalars, x and y are vectors and A is an - ++ m by n matrix. - ++ Parameters: - ++ \begin{items} - ++ \item {trans}: on entry, specifies the operation to be performed as - ++ follows: - ++ trans = 'N' or 'n' y := alpha*A*x + beta*y. - ++ trans = 'T' or 't' y := alpha*A'*x + beta*y. - ++ Unchanged on exit. - ++ \item {alpha}: on entry, specifies the scalar alpha. - ++ Unchanged on exit. - ++ \item {A}: before entry, the array A must - ++ contain the matrix of coefficients. Unchanged on exit. - ++ \item {x}: array of dimension at least n when trans = 'N' or 'n' - ++ and at least m otherwise. Before entry, the array x must contain the - ++ vector x. Unchanged on exit. - ++ \item {beta}: on entry, beta specifies the scalar beta. When beta is - ++ supplied as zero then y need not be set on input. Unchanged on exit. - ++ \item {y}: array of dimension at least m when trans = 'N' or 'n' - ++ and at least n otherwise. Before entry with beta non-zero, - ++ the array y must contain the vector y. - ++ On exit, y is overwritten by the updated vector y. - ++ \end{items} - - ger: (SI,SI,R,V,SI,V,SI,M,SI) -> Void - ++ ger(m,n,alpha,x,incx,y,incy,A,lda) performs the rank 1 operation - ++ A := alpha*x*y' + A, - ++ where alpha is a scalar, x is an m-element vector, y is an n-element - ++ vector and A is an m by n matrix. - ++ Parameters: - ++ \begin{items} - ++ \item {m}: on entry, specifies the number of rows of the matrix A. - ++ m must be at least zero. Unchanged on exit. - ++ \item {n}: on entry, specifies the number of columns of the matrix A. - ++ n must be at least zero. Unchanged on exit. - ++ \item {alpha}: on entry, specifies the scalar alpha. - ++ Unchanged on exit. - ++ \item {x}: array of dimension at least ( 1 + ( m - 1 )*abs( incx ) ). - ++ Before entry, the incremented array x must contain the - ++ m-element vector x. Unchanged on exit. - ++ \item {incx}: increment for the elements of x. - ++ \item {y}: array of dimension at least ( 1 + ( n - 1 )*abs( incy ) ). - ++ Before entry, the incremented array y must contain the - ++ n-element vector y. - ++ Unchanged on exit. - ++ \item {incy}: increment for the elements of y. - ++ \item {A}: before entry, the leading m by n part of the array A must - ++ contain the matrix of coefficients. On exit, A is overwritten by the - ++ updated matrix. - ++ \item {lda}: on entry, specifies the first dimension of A as declared - ++ in the calling (sub) program. lda must be at least max( 1, m ). - ++ Unchanged on exit. - ++ \end{items} - - ger: (R,V,V,M) -> Void - ++ ger(alpha,x,y,A) performs the rank 1 operation - ++ A := alpha*x*y' + A, - ++ where alpha is a scalar, x is an m-element vector, y is an n-element - ++ vector and A is an m by n matrix. - ++ Parameters: - ++ \begin{items} - ++ \item {alpha}: on entry, specifies the scalar alpha. - ++ Unchanged on exit. - ++ \item {x}: array of dimension at least m. Before entry, - ++ the array x must - ++ contain the m-element vector x. Unchanged on exit. - ++ \item {y}: array of dimension at least n. - ++ Before entry, the array y must - ++ contain the n-element vector y. Unchanged on exit. - ++ \item {A}: before entry, the array A must - ++ contain the matrix of coefficients. On exit, A is overwritten by the - ++ updated matrix. - ++ \end{items} - - symv: (CHAR,SI,R,M,SI,V,SI,R,V,SI) -> Void - ++ symv(uplo,n,alpha,A,lda,x,incx,beta,y,incy) - ++ performs the matrix-vector operation - ++ y := alpha*A*x + beta*y, - ++ where alpha and beta are scalars, x and y are n-element vectors and - ++ A is an n by n symmetric matrix. - ++ Parameters: - ++ \begin{items} - ++ \item {uplo}: on entry, uplo specifies whether the upper or lower - ++ triangular part of the array A is to be referenced as - ++ follows: - ++ uplo = 'U' or 'u' only the upper triangular part of A - ++ is to be referenced. - ++ uplo = 'L' or 'l' only the lower triangular part of A - ++ is to be referenced. - ++ Unchanged on exit. - ++ \item {n}: on entry, specifies the order of the matrix A. - ++ n must be at least zero. Unchanged on exit. - ++ \item {alpha}: on entry, specifies the scalar alpha. - ++ Unchanged on exit. - ++ \item {A}: before entry with uplo = 'U' or 'u', the leading n by n - ++ upper triangular part of the array A must contain the upper - ++ triangular part of the symmetric matrix and the strictly - ++ lower triangular part of A is not referenced. - ++ Before entry with uplo = 'L' or 'l', the leading n by n - ++ lower triangular part of the array A must contain the lower - ++ triangular part of the symmetric matrix and the strictly - ++ upper triangular part of A is not referenced. - ++ Unchanged on exit. - ++ \item {x}: array of dimension at least ( 1 + ( n - 1 )*abs( incx ) ) - ++ Before entry, the incremented array x must contain the - ++ n-element vector x. Unchanged on exit. - ++ \item {incx}: increment for the elements of x. - ++ \item {beta}: on entry, beta specifies the scalar beta. When beta is - ++ supplied as zero then y need not be set on input. Unchanged on exit. - ++ \item {y}: array of dimension at least ( 1 + ( n - 1 )*abs( incy ) ). - ++ Before entry with beta non-zero, the incremented array y must contain - ++ the n-element vector y. On exit, y is overwritten by the - ++ updated vector y. - ++ \item {incy}: increment for the elements of y. - ++ \end{items} - - symv: (CHAR,R,M,V,R,V) -> Void - ++ symv(uplo,alpha,A,x,beta,y) performs the matrix-vector operation - ++ y := alpha*A*x + beta*y, - ++ where alpha and beta are scalars, x and y are n-element vectors and - ++ A is an n by n symmetric matrix. - ++ Parameters: - ++ \begin{items} - ++ \item {uplo}: on entry, uplo specifies whether the upper or lower - ++ triangular part of the array A is to be referenced as - ++ follows: - ++ uplo = 'U' or 'u' only the upper triangular part of A - ++ is to be referenced. - ++ uplo = 'L' or 'l' only the lower triangular part of A - ++ is to be referenced. - ++ Unchanged on exit. - ++ \item {alpha}: on entry, specifies the scalar alpha. - ++ Unchanged on exit. - ++ \item {A}: before entry with uplo = 'U' or 'u', the - ++ upper triangular part of the array A must contain the upper - ++ triangular part of the symmetric matrix and the strictly - ++ lower triangular part of A is not referenced. - ++ Before entry with uplo = 'L' or 'l', the - ++ lower triangular part of the array A must contain the lower - ++ triangular part of the symmetric matrix and the strictly - ++ upper triangular part of A is not referenced. - ++ Unchanged on exit. - ++ \item {x}: array of dimension at least n. - ++ Before entry, the array x must contain the - ++ n-element vector x. Unchanged on exit. - ++ \item {beta}: on entry, beta specifies the scalar beta. When beta is - ++ supplied as zero then y need not be set on input. Unchanged on exit. - ++ \item {y}: array of dimension at least n. - ++ Before entry with beta non-zero, the array y must contain - ++ the n-element vector y. On exit, y is overwritten by the - ++ updated vector y. - ++ \end{items} - - syr: (CHAR,SI,R,V,SI,M,SI) -> Void - ++ syr(uplo,n,alpha,x,incx,A,lda) performs the symmetric rank 1 operation - ++ A := alpha*x*x' + A, - ++ where alpha is a scalar, x is an n-element vector and A is an - ++ n by n symmetric matrix. - ++ Parameters: - ++ \begin{items} - ++ \item {uplo}: on entry, uplo specifies whether the upper or lower - ++ triangular part of the array A is to be referenced as - ++ follows: - ++ uplo = 'U' or 'u' only the upper triangular part of A - ++ is to be referenced. - ++ uplo = 'L' or 'l' only the lower triangular part of A - ++ is to be referenced. - ++ Unchanged on exit. - ++ \item {n}: on entry, specifies the order of the matrix A. - ++ n must be at least zero. Unchanged on exit. - ++ \item {alpha}: on entry, specifies the scalar alpha. - ++ Unchanged on exit. - ++ \item {x}: array of dimension at least ( 1 + ( n - 1 )*abs( incx ) ). - ++ Before entry, the incremented array x must contain the - ++ n-element vector x. - ++ Unchanged on exit. - ++ \item {incx}: increment for the elements of x. - ++ \item {A}: before entry with uplo = 'U' or 'u', the leading n by n - ++ upper triangular part of the array A must contain the upper - ++ triangular part of the symmetric matrix and the strictly - ++ lower triangular part of A is not referenced. On exit, the - ++ upper triangular part of the array A is overwritten by the - ++ upper triangular part of the updated matrix. - ++ Before entry with uplo = 'L' or 'l', the leading n by n - ++ lower triangular part of the array A must contain the lower - ++ triangular part of the symmetric matrix and the strictly - ++ upper triangular part of A is not referenced. On exit, the - ++ lower triangular part of the array A is overwritten by the - ++ lower triangular part of the updated matrix. - ++ \item {lda}: on entry, specifies the first dimension of A as declared - ++ in the calling (sub) program. lda must be at least max( 1, n ). - ++ Unchanged on exit. - ++ \end{items} - - syr: (CHAR,R,V,M) -> Void - ++ syr(uplo,alpha,x,A) performs the symmetric rank 1 operation - ++ A := alpha*x*x' + A, - ++ where alpha is a scalar, x is an n-element vector and A is an - ++ n by n symmetric matrix. - ++ Parameters: - ++ \begin{items} - ++ \item {uplo}: on entry, uplo specifies whether the upper or lower - ++ triangular part of the array A is to be referenced as - ++ follows: - ++ uplo = 'U' or 'u' only the upper triangular part of A - ++ is to be referenced. - ++ uplo = 'L' or 'l' only the lower triangular part of A - ++ is to be referenced. - ++ Unchanged on exit. - ++ \item {alpha}: on entry, specifies the scalar alpha. - ++ Unchanged on exit. - ++ \item {x}: array of dimension at least ( 1 + ( n - 1 )*abs( incx ) ). - ++ Before entry, the array x must contain the n-element vector x. - ++ Unchanged on exit. - ++ \item {A}: before entry with uplo = 'U' or 'u', the - ++ upper triangular part of the array A must contain the upper - ++ triangular part of the symmetric matrix and the strictly - ++ lower triangular part of A is not referenced. On exit, the - ++ upper triangular part of the array A is overwritten by the - ++ upper triangular part of the updated matrix. - ++ Before entry with uplo = 'L' or 'l', the - ++ lower triangular part of the array A must contain the lower - ++ triangular part of the symmetric matrix and the strictly - ++ upper triangular part of A is not referenced. On exit, the - ++ lower triangular part of the array A is overwritten by the - ++ lower triangular part of the updated matrix. - ++ \end{items} - - syr2: (CHAR,SI,R,V,SI,V,SI,M,SI) -> Void - ++ syr2(uplo,n,alpha,x,incx,y,incy,A,lda) - ++ performs the symmetric rank 2 operation - ++ A := alpha*x*y' + alpha*y*x' + A, - ++ where alpha is a scalar, x and y are n-element vectors and A is an n - ++ by n symmetric matrix. - ++ Parameters: - ++ \begin{items} - ++ \item {uplo}: on entry, uplo specifies whether the upper or lower - ++ triangular part of the array A is to be referenced as - ++ follows: - ++ uplo = 'U' or 'u' only the upper triangular part of A - ++ is to be referenced. - ++ uplo = 'L' or 'l' only the lower triangular part of A - ++ is to be referenced. - ++ Unchanged on exit. - ++ \item {n}: on entry, specifies the order of the matrix A. - ++ n must be at least zero. Unchanged on exit. - ++ \item {alpha}: on entry, specifies the scalar alpha. - ++ Unchanged on exit. - ++ \item {x}: array of dimension at least ( 1 + ( n - 1 )*abs( incx ) ). - ++ Before entry, the incremented array x must contain the - ++ n-element vector x. - ++ Unchanged on exit. - ++ \item {incx}: increment for the elements of x. - ++ \item {y}: array of dimension at least ( 1 + ( n - 1 )*abs( incy ) ). - ++ Before entry, the incremented array y must contain the - ++ n-element vector y. - ++ Unchanged on exit. - ++ \item {incy}: increment for the elements of y. - ++ \item {A}: before entry with uplo = 'U' or 'u', the leading n by n - ++ upper triangular part of the array A must contain the upper - ++ triangular part of the symmetric matrix and the strictly - ++ lower triangular part of A is not referenced. On exit, the - ++ upper triangular part of the array A is overwritten by the - ++ upper triangular part of the updated matrix. - ++ Before entry with uplo = 'L' or 'l', the leading n by n - ++ lower triangular part of the array A must contain the lower - ++ triangular part of the symmetric matrix and the strictly - ++ upper triangular part of A is not referenced. On exit, the - ++ lower triangular part of the array A is overwritten by the - ++ lower triangular part of the updated matrix. - ++ \item {lda}: on entry, specifies the first dimension of A as declared - ++ in the calling (sub) program. lda must be at least max( 1, n ). - ++ Unchanged on exit. - ++ \end{items} - - syr2: (CHAR,R,V,V,M) -> Void - ++ syr2(uplo,alpha,x,y,A) performs the symmetric rank 2 operation - ++ A := alpha*x*y' + alpha*y*x' + A, - ++ where alpha is a scalar, x and y are n-element vectors and A is an n - ++ by n symmetric matrix. - ++ Parameters: - ++ \begin{items} - ++ \item {uplo}: on entry, uplo specifies whether the upper or lower - ++ triangular part of the array A is to be referenced as - ++ follows: - ++ uplo = 'U' or 'u' only the upper triangular part of A - ++ is to be referenced. - ++ uplo = 'L' or 'l' only the lower triangular part of A - ++ is to be referenced. - ++ Unchanged on exit. - ++ \item {n}: on entry, specifies the order of the matrix A. - ++ n must be at least zero. Unchanged on exit. - ++ \item {alpha}: on entry, specifies the scalar alpha. - ++ Unchanged on exit. - ++ \item {x}: array of dimension at least n. - ++ Before entry, the array x must contain the n-element vector x. - ++ Unchanged on exit. - ++ \item {y}: array of dimension at least n. - ++ Before entry, the array y must contain the n-element vector y. - ++ Unchanged on exit. - ++ \item {A}: before entry with uplo = 'U' or 'u', the leading n by n - ++ upper triangular part of the array A must contain the upper - ++ triangular part of the symmetric matrix and the strictly - ++ lower triangular part of A is not referenced. On exit, the - ++ upper triangular part of the array A is overwritten by the - ++ upper triangular part of the updated matrix. - ++ Before entry with uplo = 'L' or 'l', the leading n by n - ++ lower triangular part of the array A must contain the lower - ++ triangular part of the symmetric matrix and the strictly - ++ upper triangular part of A is not referenced. On exit, the - ++ lower triangular part of the array A is overwritten by the - ++ lower triangular part of the updated matrix. - ++ \end{items} - - trmv: (CHAR,CHAR,CHAR,SI,M,SI,V,SI) -> Void - ++ trmv(uplo,trans,diag,n,A,lda,x,incx) - ++ performs one of the matrix-vector operations - ++ x := A*x, or x := A'*x, - ++ where x is an n-element vector and A is an n by n unit, or non-unit, - ++ upper or lower triangular matrix. - ++ Parameters: - ++ \begin{items} - ++ \item {uplo}: on entry, specifies whether the matrix is an upper or - ++ lower triangular matrix as follows: - ++ uplo = 'U' or 'u' A is an upper triangular matrix. - ++ uplo = 'L' or 'l' A is a lower triangular matrix. - ++ Unchanged on exit. - ++ \item {trans}: on entry, specifies the operation to be performed as - ++ follows: - ++ trans = 'N' or 'n' x := A*x. - ++ trans = 'T' or 't' x := A'*x. - ++ Unchanged on exit. - ++ \item {diag}: on entry, specifies whether or not A is unit - ++ triangular as follows: - ++ diag = 'U' or 'u' A is assumed to be unit triangular. - ++ diag = 'N' or 'n' A is not assumed to be unit triangular. - ++ Unchanged on exit - ++ \item {n}: on entry, specifies the order of the matrix A. - ++ n must be at least zero. Unchanged on exit. - ++ \item {A}: before entry with uplo = 'U' or 'u', the leading n by n - ++ upper triangular part of the array A must contain the upper - ++ triangular matrix and the strictly lower triangular part of - ++ A is not referenced. - ++ Before entry with uplo = 'L' or 'l', the leading n by n - ++ lower triangular part of the array A must contain the lower triangular - ++ matrix and the strictly upper triangular part of A is not referenced. - ++ Note that when diag = 'U' or 'u', the diagonal elements of A are not - ++ referenced either, but are assumed to be unity. Unchanged on exit. - ++ \item {lda}: on entry, specifies the first dimension of A as declared - ++ in the calling (sub) program. lda must be at least max( 1, n ). - ++ Unchanged on exit. - ++ \item {x}: array of dimension at least ( 1 + ( n - 1 )*abs( incx ) ). - ++ Before entry, the incremented array x must contain the - ++ n-element vector x. - ++ On exit, x is overwritten with the tranformed vector x. - ++ \item {incx}: increment for the elements of x. - ++ \end{items} - - trmv: (CHAR,CHAR,CHAR,M,V) -> Void - ++ trmv(uplo,trans,diag,A,x) performs one of the matrix-vector operations - ++ x := A*x, or x := A'*x, - ++ where x is an n-element vector and A is an n by n unit, or non-unit, - ++ upper or lower triangular matrix. - ++ Parameters: - ++ \begin{items} - ++ \item {uplo}: on entry, specifies whether the matrix is an upper or - ++ lower triangular matrix as follows: - ++ uplo = 'U' or 'u' A is an upper triangular matrix. - ++ uplo = 'L' or 'l' A is a lower triangular matrix. - ++ Unchanged on exit. - ++ \item {trans}: on entry, specifies the operation to be performed as - ++ follows: - ++ trans = 'N' or 'n' x := A*x. - ++ trans = 'T' or 't' x := A'*x. - ++ Unchanged on exit. - ++ \item {diag}: on entry, specifies whether or not A is unit - ++ triangular as follows: - ++ diag = 'U' or 'u' A is assumed to be unit triangular. - ++ diag = 'N' or 'n' A is not assumed to be unit triangular. - ++ Unchanged on exit - ++ \item {A}: before entry with uplo = 'U' or 'u', the - ++ upper triangular part of the array A must contain the upper - ++ triangular matrix and the strictly lower triangular part of - ++ A is not referenced. Before entry with uplo = 'L' or 'l', the - ++ lower triangular part of the array A must contain the lower triangular - ++ matrix and the strictly upper triangular part of A is not referenced. - ++ Note that when diag = 'U' or 'u', the diagonal elements of A are not - ++ referenced either, but are assumed to be unity. Unchanged on exit. - ++ \item {x}: array of dimension at least n. - ++ Before entry, the array x must contain the n-element vector x. - ++ On exit, x is overwritten with the tranformed vector x. - ++ \end{items} - - trsv: (CHAR,CHAR,CHAR,SI,M,SI,V,SI) -> Void - ++ trsv(uplo,trans,diag,n,A,lda,x,incx) - ++ solves one of the systems of equations - ++ A*x = b, or A'*x = b, - ++ where b and x are n-element vectors and A is an n by n unit, or - ++ non-unit, upper or lower triangular matrix. - ++ No test for singularity or near-singularity is included in this - ++ routine. Such tests must be performed before calling this routine. - ++ Parameters: - ++ \begin{items} - ++ \item {uplo}: on entry, specifies whether the matrix is an upper or - ++ lower triangular matrix as follows: - ++ uplo = 'U' or 'u' A is an upper triangular matrix. - ++ uplo = 'L' or 'l' A is a lower triangular matrix. - ++ Unchanged on exit. - ++ \item {trans}: on entry, specifies the equations to be solved as - ++ follows: - ++ trans = 'N' or 'n' A*x = b. - ++ trans = 'T' or 't' A'*x = b. - ++ Unchanged on exit. - ++ \item {diag}: on entry, specifies whether or not A is unit - ++ triangular as follows: - ++ diag = 'U' or 'u' A is assumed to be unit triangular. - ++ diag = 'N' or 'n' A is not assumed to be unit triangular. - ++ Unchanged on exit - ++ \item {n}: on entry, specifies the order of the matrix A. - ++ n must be at least zero. Unchanged on exit. - ++ \item {A}: before entry with uplo = 'U' or 'u', the leading n by n - ++ upper triangular part of the array A must contain the upper - ++ triangular matrix and the strictly lower triangular part of - ++ A is not referenced. Before entry with uplo = 'L' or 'l', - ++ the leading n by n - ++ lower triangular part of the array A must contain the lower triangular - ++ matrix and the strictly upper triangular part of A is not referenced. - ++ Note that when diag = 'U' or 'u', the diagonal elements of A are not - ++ referenced either, but are assumed to be unity. Unchanged on exit. - ++ \item {lda}: on entry, specifies the first dimension of A as declared - ++ in the calling (sub) program. lda must be at least max( 1, n ). - ++ Unchanged on exit. - ++ \item {x}: array of dimension at least ( 1 + ( n - 1 )*abs( incx ) ). - ++ Before entry, the incremented array x must contain the - ++ n-element right-hand side vector b. On exit, x is overwritten - ++ with the solution vector x. - ++ \item {incx}: increment for the elements of x. - ++ \end{items} - - trsv: (CHAR,CHAR,CHAR,M,V) -> Void - ++ trsv(uplo,trans,diag,A,x) solves one of the systems of equations - ++ A*x = b, or A'*x = b, - ++ where b and x are n-element vectors and A is an n by n unit, or - ++ non-unit, upper or lower triangular matrix. - ++ No test for singularity or near-singularity is included in this - ++ routine. Such tests must be performed before calling this routine. - ++ Parameters: - ++ \begin{items} - ++ \item {uplo}: on entry, specifies whether the matrix is an upper or - ++ lower triangular matrix as follows: - ++ uplo = 'U' or 'u' A is an upper triangular matrix. - ++ uplo = 'L' or 'l' A is a lower triangular matrix. - ++ Unchanged on exit. - ++ \item {trans}: on entry, specifies the equations to be solved as - ++ follows: - ++ trans = 'N' or 'n' A*x = b. - ++ trans = 'T' or 't' A'*x = b. - ++ Unchanged on exit. - ++ \item {diag}: on entry, specifies whether or not A is unit - ++ triangular as follows: - ++ diag = 'U' or 'u' A is assumed to be unit triangular. - ++ diag = 'N' or 'n' A is not assumed to be unit triangular. - ++ Unchanged on exit - ++ \item {A}: before entry with uplo = 'U' or 'u', the - ++ upper triangular part of the array A must contain the upper - ++ triangular matrix and the strictly lower triangular part of - ++ A is not referenced. Before entry with uplo = 'L' or 'l', the - ++ lower triangular part of the array A must contain the lower triangular - ++ matrix and the strictly upper triangular part of A is not referenced. - ++ Note that when diag = 'U' or 'u', the diagonal elements of A are not - ++ referenced either, but are assumed to be unity. Unchanged on exit. - ++ \item {x}: array of dimension at least n. - ++ Before entry, the array x must contain the - ++ n-element right-hand side vector b. On exit, x is overwritten - ++ with the solution vector x. - ++ \end{items} +\chapter{BLAS Support Code} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dcabs1 BLAS} +%\pagehead{dcabs1}{dcabs1} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - Implementation == add +The argument is: +\begin{itemize} +\item z - (complex double-float) +\end{itemize} - gemv(trans:CHAR,m:SI,n:SI,alpha:R,A:M,lda:SI,x:V,incx:SI,beta:R,y:V,incy:SI): Void == - DGEMV(trans,m,n,alpha,A,lda,x,incx,beta,y,incy)$Lisp - - gemv(trans:CHAR,alpha:R,A:M,x:V,beta:R,y:V): Void == - m := nrows(A)::SI - n := ncols(A)::SI - nx := #x - ny := #y - if ((trans = char "N") or (trans = char "n")) then - nx < n => - error "gemv: #x must be at least ncols(A)" - ny < m => - error "gemv: #y must be at least nrows(A)" - else if ((trans = char "T") or (trans = char "t")) then - nx < m => - error "gemv: #x must be at least nrows(A)" - ny < n => - error "gemv: #y must be at least ncols(A)" - else - error "gemv: trans must be one of the following values: N, n, T or t" - DGEMV(trans,m,n,alpha,A,m,x,1$SI,beta,y,1$SI)$Lisp - - ger(m:SI,n:SI,alpha:R,x:V,incx:SI,y:V,incy:SI,A:M,lda:SI): Void == - DGER(m,n,alpha,x,incx,y,incy,A,lda)$Lisp - - ger(alpha:R,x:V,y:V,A:M): Void == - m := nrows(A)::SI - n := ncols(A)::SI - #x < m => - error "gemv: #x must be at least nrows(A)" - #y < n => - error "gemv: #y must be at least ncols(A)" - DGER(m,n,alpha,x,1$SI,y,1$SI,A,m)$Lisp - - symv(uplo:CHAR,n:SI,alpha:R,A:M,lda:SI,x:V,incx:SI,beta:R,y:V,incy:SI): Void == - DSYMV(uplo,n,alpha,A,lda,x,incx,beta,y,incy)$Lisp - - symv(uplo:CHAR,alpha:R,A:M,x:V,beta:R,y:V): Void == - (n := nrows(A)::SI) < ncols(A) => - error "symv: nrows(A) must be at least ncols(A)" - (#x < n) => - error "symv: #x must be at least nrows(A)" - (#y < n) => - error "symv: #y must be at least nrows(A)" - (uplo ~= char "U") and (uplo ~= char "u") and (uplo ~= char "L") and_ - (uplo ~= char "l") => - error "symv: uplo must be one of the following values: u, U, l or L" - DSYMV(uplo,n,alpha,A,n,x,1$SI,beta,y,1$SI)$Lisp - - syr(uplo:CHAR,n:SI,alpha:R,x:V,incx:SI,A:M,lda:SI): Void == - DSYR(uplo,n,alpha,x,incx,A,lda)$Lisp - - syr(uplo:CHAR,alpha:R,x:V,A:M): Void == - (n := nrows(A)::SI) < ncols(A) => - error "syr: nrows(A) must be at least ncols(A)" - (#x < n) => - error "syr: #x must be at least nrows(A)" - (uplo ~= char "U") and (uplo ~= char "u") and (uplo ~= char "L") and_ - (uplo ~= char "l") => - error "syr: uplo must be one of the following values: u, U, l or L" - DSYR(uplo,n,alpha,x,1$SI,A,n)$Lisp - - syr2(uplo:CHAR,n:SI,alpha:R,x:V,incx:SI,y:V,incy:SI,A:M,lda:SI): Void == - DSYR2(uplo,n,alpha,x,incx,y,incy,A,lda)$Lisp - - syr2(uplo:CHAR,alpha:R,x:V,y:V,A:M): Void == - (n := nrows(A)::SI) < ncols(A) => - error "syr2: nrows(A) must be at least ncols(A)" - (#x < n) => - error "syr2: #x must be at least nrows(A)" - (#y < n) => - error "syr2: #y must be at least nrows(A)" - (uplo ~= char "U") and (uplo ~= char "u") and (uplo ~= char "L") and_ - (uplo ~= char "l") => - error "syr2: uplo must be one of the following values: u, U, l or L" - DSYR2(uplo,n,alpha,x,1$SI,A,n)$Lisp - - trmv(uplo:CHAR,trans:CHAR,diag:CHAR,n:SI,A:M,lda:SI,x:V,incx:SI): Void == - DTRMV(uplo,trans,diag,n,A,lda,x,incx)$Lisp - - trmv(uplo:CHAR,trans:CHAR,diag:CHAR,A:M,x:V): Void == - (n := nrows(A)::SI) < ncols(A) => - error "trmv: nrows(A) must be at least ncols(A)" - (#x < n) => - error "trmv: #x must be at least nrows(A)" - (trans ~= char "N") and (trans ~= char "n") and (trans ~= char "T") and_ - (trans ~= char "t") => - error "trmv: trans must be one of the following values: N, n, T or t" - (uplo ~= char "U") and (uplo ~= char "u") and (uplo ~= char "L") and_ - (uplo ~= char "l") => - error "trmv: uplo must be one of the following values: u, U, l or L" - (diag ~= char "N") and (diag ~= char "n") and (diag ~= char "U") and_ - (diag ~= char "u") => - error "trmv: diag must be one of the following values: N, n, U or u" - DTRMV(uplo,trans,diag,n,A,n,x,1$SI)$Lisp - - trsv(uplo:CHAR,trans:CHAR,diag:CHAR,n:SI,A:M,lda:SI,x:V,incx:SI): Void == - DTRSV(uplo,trans,diag,n,A,lda,x,incx)$Lisp - - trsv(uplo:CHAR,trans:CHAR,diag:CHAR,A:M,x:V): Void == - (n := nrows(A)::SI) < ncols(A) => - error "trsv: nrows(A) must be at least ncols(A)" - (#x < n) => - error "trsv: #x must be at least nrows(A)" - (trans ~= char "N") and (trans ~= char "n") and (trans ~= char "T") and_ - (trans ~= char "t") => - error "trsv: trans must be one of the following values: N, n, T or t" - (uplo ~= char "U") and (uplo ~= char "u") and (uplo ~= char "L") and_ - (uplo ~= char "l") => - error "trsv: uplo must be one of the following values: u, U, l or L" - (diag ~= char "N") and (diag ~= char "n") and (diag ~= char "U") and_ - (diag ~= char "u") => - error "trsv: diag must be one of the following values: N, n, U or u" - DTRSV(uplo,trans,diag,n,A,n,x,1$SI)$Lisp +The result is +\begin{itemize} +\item (+ (abs (realpart z)) (abs (imagpart z))) +\item nil +\end{itemize} -@ -<>= -"BLAS2" [color="#FF4488",href="bookvol10.4.pdf#nameddest=BLAS2"] -"FS" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FS"] -"ACF" [color="#4488FF",href="bookvol10.2.pdf#nameddest=ACF"] -"BLAS2" -> "FS" -"BLAS2" -> "ACF" +Axiom represents the type Complex(DoubleFloat) as a pair whose car is +the real part and whose cdr is the imaginary part. +<>= +(defun dcabs1 (z) + "Complex(DoubleFloat) z is a pair where (realpart . imaginarypart)" + (the double-float + (+ + (the double-float (abs (the double-float (car z)))) + (the double-float (abs (the double-float (cdr z))))))) @ - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{package BLAS3 BlasLevelThree} -\pagehead{BlasLevelThree}{BLAS3} -%\pagepic{ps/v104blaslevelthree.ps}{BLAS3}{1.00} - -{\bf Exports:}\\ -\begin{tabular}{lllll} -\cross{BLAS3}{?**?} & -\end{tabular} - -<>= -)abbrev package BLAS3 BlasLevelThree -++ Author: Gregory Vanuxem -++ Date Created: 2006 -++ Date Last Updated: Sep 9, 2006 -++ Basic Operations: -++ Related Domains: ColumnMajorTwoDimensionnalArray -++ Also See: -++ AMS Classifications: -++ Keywords: -++ Examples: -++ References: -++ Description: -++ This package provides an interface to the -++ Blas library (level 3) --- TODO: "at least" verification -BlasLevelThree(Row,Col,M) : Exports == Implementation where - - R ==> DoubleFloat - SI ==> SingleInteger - CHAR ==> Character - Row : OneDimensionalArrayAggregate(R) with contiguousStorage - Col : OneDimensionalArrayAggregate(R) with contiguousStorage - M : ColumnMajorTwoDimensionalArrayCategory(R,Row,Col) - - Exports == with - - gemm: (CHAR,CHAR,SI,SI,SI,R,M,SI,M,SI,R,M,SI) -> Void - ++ gemm(transa,transb,m,n,k,alpha,A,lda,B,ldb,beta,C,ldc) performs one - ++ of the matrix-matrix operations - ++ C := alpha*op( A )*op( B ) + beta*C, - ++ where op( X ) is one of - ++ op( X ) = X or op( X ) = X', - ++ alpha and beta are scalars, and A, B and C are matrices, with op( A ) - ++ an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. - ++ Parameters: - ++ \begin{items} - ++ \item {transa}: on entry, specifies the form of op( A ) to be used in - ++ the matrix multiplication as follows: - ++ transa = 'N' or 'n', op( A ) = A. - ++ transa = 'T' or 't', op( A ) = A'. - ++ Unchanged on exit. - ++ \item{transb}: on entry, specifies the form of op( B ) to be used in - ++ the matrix multiplication as follows: - ++ transb = 'N' or 'n', op( B ) = B. - ++ transb = 'T' or 't', op( B ) = B'. - ++ Unchanged on exit. - ++ \item{m}: on entry, specifies the number of rows of the matrix - ++ op( A ) and of the matrix C. m must be at least zero. - ++ Unchanged on exit. - ++ \item{n}: on entry, specifies the number of columns of the matrix - ++ op( B ) and the number of columns of the matrix C. n must be - ++ at least zero. Unchanged on exit. - ++ \item{k}: on entry, specifies the number of columns of the matrix - ++ op( A ) and the number of rows of the matrix op( B ). k must - ++ be at least zero. Unchanged on exit. - ++ \item{alpha}: on entry, specifies the scalar alpha. - ++ Unchanged on exit. - ++ \item{A}: before entry with transa = 'N' or 'n', the leading m by k - ++ part of the array A must contain the matrix A, otherwise - ++ the leading k by m part of the array A must contain the - ++ matrix A. Unchanged on exit - ++ \item{lda}: on entry, specifies the first dimension of A as declared - ++ in the calling (sub) program. When transa = 'N' or 'n' then - ++ lda must be at least max( 1, m ), otherwise lda must be at - ++ least max( 1, k ). Unchanged on exit - ++ \item{B}: before entry with transb = 'N' or 'n', - ++ the leading k by n - ++ part of the array B must contain the matrix B, otherwise - ++ the leading n by k part of the array B must contain the - ++ matrix B. Unchanged on exit. - ++ \item{ldb}: on entry, specifies the first dimension of B as declared - ++ in the calling (sub) program. When transb = 'N' or 'n' then - ++ ldb must be at least max( 1, k ), otherwise ldb must be at - ++ least max( 1, n ). Unchanged on exit. - ++ \item{beta}: on entry, specifies the scalar beta. When beta is - ++ supplied as zero then C need not be set on input. Unchanged on exit. - ++ \item{C}: before entry, the leading m by n part of the array C must - ++ contain the matrix C, except when beta is zero, in which - ++ case C need not be set on entry. - ++ On exit, the array C is overwritten by the m by n matrix - ++ ( alpha*op( A )*op( B ) + beta*C ). - ++ \item{ldc}: on entry, specifies the first dimension of C as declared - ++ in the calling (sub) program. ldc must be at least - ++ max( 1, m ). Unchanged on exit. - ++ \end{items} - - gemm: (CHAR,CHAR,R,M,M,R,M) -> Void - ++ gemm(transa,transb,alpha,A,B,beta,C) performs one - ++ of the matrix-matrix operations - ++ C := alpha*op( A )*op( B ) + beta*C, - ++ where op( X ) is one of - ++ op( X ) = X or op( X ) = X', - ++ alpha and beta are scalars, and A, B and C are matrices, with op( A ) - ++ an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. - ++ Parameters: - ++ \begin{items} - ++ \item {transa}: on entry, specifies the form of op( A ) to be used in - ++ the matrix multiplication as follows: - ++ transa = 'N', op( A ) = A. - ++ transa = 'T', op( A ) = A'. - ++ Unchanged on exit. - ++ \item{transb}: on entry, specifies the form of op( B ) to be used in - ++ the matrix multiplication as follows: - ++ transb = 'N', op( B ) = B. - ++ transb = 'T', op( B ) = B'. - ++ Unchanged on exit. - ++ \item{alpha}: on entry, specifies the scalar alpha. - ++ Unchanged on exit. - ++ \item{A}: before entry with transa = 'N' or 'n', the leading m by k - ++ part of the array A must contain the matrix A, otherwise - ++ the leading k by m part of the array A must contain the - ++ matrix A. Unchanged on exit - ++ \item{B}: before entry with transb = 'N' or 'n', - ++ the leading k by n - ++ part of the array B must contain the matrix B, otherwise - ++ the leading n by k part of the array B must contain the - ++ matrix B. Unchanged on exit. - ++ \item{beta}: on entry, specifies the scalar beta. When beta is - ++ supplied as zero then C need not be set on input. Unchanged on exit. - ++ \item{C}: before entry, the leading m by n part of the array C must - ++ contain the matrix C, except when beta is zero, in which - ++ case C need not be set on entry. - ++ On exit, the array C is overwritten by the m by n matrix - ++ ( alpha*op( A )*op( B ) + beta*C ). - ++ \end{items} - - symm: (CHAR,CHAR,SI,SI,R,M,SI,M,SI,R,M,SI) -> Void - ++ symm(side,uplo,m,n,alpha,A,lda,B,ldb,beta,C,ldc) performs one of - ++ the matrix-matrix operations - ++ C := alpha*A*B + beta*C, or C := alpha*B*A + beta*C, - ++ where alpha and beta are scalars, A is a symmetric matrix and B and - ++ C are m by n matrices. - ++ Parameters: - ++ \begin{items} - ++ \item {side}: on entry, specifies whether the symmetric matrix A - ++ appears on the left or right in the operation as follows: - ++ side = 'L' or 'l' C := alpha*A*B + beta*C, - ++ side = 'R' or 'r' C := alpha*B*A + beta*C, - ++ Unchanged on exit. - ++ \item{uplo}: on entry, specifies whether the upper or lower - ++ triangular part of the symmetric matrix A is to be - ++ referenced as follows: - ++ uplo = 'U' or 'u' Only the upper triangular part of the - ++ symmetric matrix is to be referenced. - ++ uplo = 'L' or 'l' Only the lower triangular part of the - ++ symmetric matrix is to be referenced. - ++ Unchanged on exit. - ++ \item{m}: on entry, specifies the number of rows of the matrix C. - ++ m must be at least zero. Unchanged on exit. - ++ \item{n}: on entry, specifies the number of columns of the matrix C. - ++ n must be at least zero. Unchanged on exit. - ++ \item{alpha}: on entry, specifies the scalar alpha. - ++ Unchanged on exit. - ++ \item{A}: before entry with side = 'L' or 'l', the m by m part of - ++ the array A must contain the symmetric matrix, such that - ++ when uplo = 'U' or 'u', the leading m by m upper triangular - ++ part of the array A must contain the upper triangular part - ++ of the symmetric matrix and the strictly lower triangular - ++ part of A is not referenced, and when uplo = 'L' or 'l', - ++ the leading m by m lower triangular part of the array A - ++ must contain the lower triangular part of the symmetric - ++ matrix and the strictly upper triangular part of A is not - ++ referenced. - ++ Before entry with side = 'R' or 'r', the n by n part of - ++ the array A must contain the symmetric matrix, such that - ++ when uplo = 'U' or 'u', the leading n by n upper triangular - ++ part of the array A must contain the upper triangular part - ++ of the symmetric matrix and the strictly lower triangular - ++ part of A is not referenced, and when uplo = 'L' or 'l', - ++ the leading n by n lower triangular part of the array A - ++ must contain the lower triangular part of the symmetric - ++ matrix and the strictly upper triangular part of A is not - ++ referenced. Unchanged on exit. - ++ \item{lda}: on entry, specifies the first dimension of A as declared - ++ in the calling (sub) program. When side = 'L' or 'l' then - ++ lda must be at least max( 1, m ), otherwise lda must be at - ++ least max( 1, n ). Unchanged on exit. - ++ \item{B}: Before entry, the leading m by n part of the array B must - ++ contain the matrix B. Unchanged on exit. - ++ \item{ldb}: on entry, ldb specifies the first dimension of B as - ++ declared in the calling (sub) program. ldb must be at - ++ least max( 1, m ). - ++ Unchanged on exit. - ++ \item{beta}: on entry, specifies the scalar beta. When beta is - ++ supplied as zero then C need not be set on input. Unchanged on exit. - ++ \item{C}: before entry, the leading m by n part of the array C must - ++ contain the matrix C, except when beta is zero, in which - ++ case C need not be set on entry. On exit, the array C is - ++ overwritten by the m by n updated matrix. - ++ \item{ldc}: on entry, specifies the first dimension of C as declared - ++ in the calling (sub) program. ldc must be at least - ++ max( 1, m ). Unchanged on exit. - ++ \end{items} - - symm: (CHAR,CHAR,R,M,M,R,M) -> Void - ++ symm(side,uplo,alpha,A,B,beta,C) performs one of - ++ the matrix-matrix operations - ++ C := alpha*A*B + beta*C, or C := alpha*B*A + beta*C, - ++ where alpha and beta are scalars, A is a symmetric matrix and B and - ++ C are m by n matrices. - ++ Parameters: - ++ \begin{items} - ++ \item {side}: on entry, specifies whether the symmetric matrix A - ++ appears on the left or right in the operation as follows: - ++ side = 'L' or 'l' C := alpha*A*B + beta*C, - ++ side = 'R' or 'r' C := alpha*B*A + beta*C, - ++ Unchanged on exit. - ++ \item{uplo}: on entry, specifies whether the upper or lower - ++ triangular part of the symmetric matrix A is to be - ++ referenced as follows: - ++ uplo = 'U' or 'u' Only the upper triangular part of the - ++ symmetric matrix is to be referenced. - ++ uplo = 'L' or 'l' Only the lower triangular part of the - ++ symmetric matrix is to be referenced. - ++ Unchanged on exit. - ++ \item{alpha}: on entry, specifies the scalar alpha. - ++ Unchanged on exit. - ++ \item{A}: before entry with side = 'L' or 'l', the m by m part of - ++ the array A must contain the symmetric matrix, such that - ++ when uplo = 'U' or 'u', the leading m by m upper triangular - ++ part of the array A must contain the upper triangular part - ++ of the symmetric matrix and the strictly lower triangular - ++ part of A is not referenced, and when uplo = 'L' or 'l', - ++ the leading m by m lower triangular part of the array A - ++ must contain the lower triangular part of the symmetric - ++ matrix and the strictly upper triangular part of A is not - ++ referenced. - ++ Before entry with side = 'R' or 'r', the n by n part of - ++ the array A must contain the symmetric matrix, such that - ++ when uplo = 'U' or 'u', the leading n by n upper triangular - ++ part of the array A must contain the upper triangular part - ++ of the symmetric matrix and the strictly lower triangular - ++ part of A is not referenced, and when uplo = 'L' or 'l', - ++ the leading n by n lower triangular part of the array A - ++ must contain the lower triangular part of the symmetric - ++ matrix and the strictly upper triangular part of A is not - ++ referenced. Unchanged on exit. - ++ \item{B}: Before entry, the leading m by n part of the array B must - ++ contain the matrix B. Unchanged on exit. - ++ \item{beta}: on entry, specifies the scalar beta. When beta is - ++ supplied as zero then C need not be set on input. Unchanged on exit. - ++ \item{C}: before entry, the leading m by n part of the array C must - ++ contain the matrix C, except when beta is zero, in which - ++ case C need not be set on entry. On exit, the array C is - ++ overwritten by the m by n updated matrix. - ++ \end{items} - - - syrk: (CHAR,CHAR,SI,SI,R,M,SI,R,M,SI) -> Void - ++ syrk(uplo,trans,n,k,alpha,A,lda,beta,C,ldc) performs one of - ++ the symmetric rank k operations - ++ C := alpha*A*A' + beta*C, or C := alpha*A'*A + beta*C, - ++ where alpha and beta are scalars, C is an n by n symmetric matrix - ++ and A is an n by k matrix in the first case and a k by n matrix - ++ in the second case. - ++ Parameters: - ++ \begin{items} - ++ \item{uplo}: on entry, specifies whether the upper or lower - ++ triangular part of the array C is to be referenced as - ++ follows: - ++ uplo = 'U' or 'u' Only the upper triangular part of C - ++ is to be referenced. - ++ uplo = 'L' or 'l' Only the lower triangular part of C - ++ is to be referenced. - ++ Unchanged on exit. - ++ \item{trans}: on entry, specifies the operation to be performed as - ++ follows: - ++ trans = 'N' or 'n' C := alpha*A*A' + beta*C. - ++ trans = 'T' or 't' C := alpha*A'*A + beta*C. - ++ Unchanged on exit. - ++ \item{n}: on entry, specifies the order of the matrix C. n must be - ++ at least zero. Unchanged on exit. - ++ \item{k}: on entry with trans = 'N' or 'n', k specifies the number - ++ of columns of the matrix A, and on entry with - ++ trans = 'T' or 't', k specifies the number - ++ of rows of the matrix A. K must be at least zero. Unchanged on exit. - ++ \item{alpha}: on entry, specifies the scalar alpha. - ++ Unchanged on exit. - ++ \item{A}: before entry with trans = 'N' or 'n', the leading n by k - ++ part of the array A must contain the matrix A, otherwise - ++ the leading k by n part of the array A must contain the - ++ matrix A. Unchanged on exit. - ++ \item{lda}: on entry, specifies the first dimension of A as declared - ++ in the calling (sub) program. When trans = 'N' or 'n' - ++ then lda must be at least max( 1, n ), otherwise lda must - ++ be at least max( 1, k ). Unchanged on exit. - ++ \item{beta}: on entry, specifies the scalar beta. Unchanged on exit. - ++ \item{C}: before entry with uplo = 'U' or 'u', the leading n by n - ++ upper triangular part of the array C must contain the upper - ++ triangular part of the symmetric matrix and the strictly - ++ lower triangular part of C is not referenced. On exit, the - ++ upper triangular part of the array C is overwritten by the - ++ upper triangular part of the updated matrix. - ++ Before entry with uplo = 'L' or 'l', the leading n by n - ++ lower triangular part of the array C must contain the lower - ++ triangular part of the symmetric matrix and the strictly - ++ upper triangular part of C is not referenced. On exit, the - ++ lower triangular part of the array C is overwritten by the - ++ lower triangular part of the updated matrix. - ++ \item{ldc}: on entry, specifies the first dimension of C as declared - ++ in the calling (sub) program. ldc must be at least - ++ max( 1, n ). Unchanged on exit. - ++ \end{items} - - syrk: (CHAR,CHAR,R,M,R,M) -> Void - ++ syrk(uplo,trans,alpha,A,beta,C) performs one of - ++ the symmetric rank k operations - ++ C := alpha*A*A' + beta*C, or C := alpha*A'*A + beta*C, - ++ where alpha and beta are scalars, C is an n by n symmetric matrix - ++ and A is an n by k matrix in the first case and a k by n matrix - ++ in the second case. - ++ Parameters: - ++ \begin{items} - ++ \item{uplo}: on entry, specifies whether the upper or lower - ++ triangular part of the array C is to be referenced as - ++ follows: - ++ uplo = 'U' or 'u' Only the upper triangular part of C - ++ is to be referenced. - ++ uplo = 'L' or 'l' Only the lower triangular part of C - ++ is to be referenced. - ++ Unchanged on exit. - ++ \item{trans}: on entry, specifies the operation to be performed as - ++ follows: - ++ trans = 'N' or 'n' C := alpha*A*A' + beta*C. - ++ trans = 'T' or 't' C := alpha*A'*A + beta*C. - ++ Unchanged on exit. - ++ \item{alpha}: on entry, specifies the scalar alpha. - ++ Unchanged on exit. - ++ \item{A}: before entry with trans = 'N' or 'n', the leading n by k - ++ part of the array A must contain the matrix A, otherwise - ++ the leading k by n part of the array A must contain the - ++ matrix A. Unchanged on exit. - ++ \item{beta}: on entry, specifies the scalar beta. Unchanged on exit. - ++ \item{C}: before entry with uplo = 'U' or 'u', the leading n by n - ++ upper triangular part of the array C must contain the upper - ++ triangular part of the symmetric matrix and the strictly - ++ lower triangular part of C is not referenced. On exit, the - ++ upper triangular part of the array C is overwritten by the - ++ upper triangular part of the updated matrix. - ++ Before entry with uplo = 'L' or 'l', the leading n by n - ++ lower triangular part of the array C must contain the lower - ++ triangular part of the symmetric matrix and the strictly - ++ upper triangular part of C is not referenced. On exit, the - ++ lower triangular part of the array C is overwritten by the - ++ lower triangular part of the updated matrix. - ++ \end{items} - - syr2k: (CHAR,CHAR,SI,SI,R,M,SI,M,SI,R,M,SI) -> Void - ++ syr2k(uplo,trans,n,k,alpha,A,lda,B,ldb,beta,C,ldc) performs one - ++ of the symmetric rank 2k operations - ++ C := alpha*A*B' + alpha*B*A' + beta*C, or - ++ C := alpha*A'*B + alpha*B'*A + beta*C, - ++ where alpha and beta are scalars, C is an n by n symmetric matrix - ++ and A and B are n by k matrices in the first case and k by n - ++ matrices in the second case. - ++ Parameters: - ++ \begin{items} - ++ \item{uplo}: on entry, specifies whether the upper or lower - ++ triangular part of the array C is to be referenced as - ++ follows: - ++ uplo = 'U' or 'u' Only the upper triangular part of C - ++ is to be referenced. - ++ uplo = 'L' or 'l' Only the lower triangular part of C - ++ is to be referenced. - ++ Unchanged on exit. - ++ \item{trans}: on entry, specifies the operation to be performed as - ++ follows: - ++ trans = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + beta*C. - ++ trans = 'T' or 't' C := alpha*A'*B + alpha*B'*A + beta*C. - ++ Unchanged on exit. - ++ \item{n}: on entry, specifies the order of the matrix C. n must be - ++ at least zero. Unchanged on exit. - ++ \item{k}: on entry with trans = 'N' or 'n', K specifies the number - ++ of columns of the matrices A and B, and on entry with - ++ trans = 'T' or 't' or 'C' or 'c', K specifies the number - ++ of rows of the matrices A and B. K must be at least zero. - ++ Unchanged on exit. - ++ \item{alpha}: on entry, specifies the scalar alpha. - ++ Unchanged on exit. - ++ \item{A}: before entry with trans = 'N' or 'n', the leading n by k - ++ part of the array A must contain the matrix A, otherwise - ++ the leading k by n part of the array A must contain the - ++ matrix A. Unchanged on exit. - ++ \item{lda}: on entry, specifies the first dimension of A as declared - ++ in the calling (sub) program. When trans = 'N' or 'n' - ++ then lda must be at least max( 1, n ), otherwise lda must - ++ be at least max( 1, k ). Unchanged on exit. - ++ \item{B}: before entry with trans = 'N' or 'n', the leading n by k - ++ part of the array B must contain the matrix B, otherwise - ++ the leading k by n part of the array B must contain the - ++ matrix B. Unchanged on exit. - ++ \item{ldb}: on entry, specifies the first dimension of B as declared - ++ in the calling (sub) program. When trans = 'N' or 'n' - ++ then ldb must be at least max( 1, n ), otherwise ldb must - ++ be at least max( 1, k ). Unchanged on exit. - ++ \item{beta}: on entry, specifies the scalar beta. Unchanged on exit. - ++ \item{C}: before entry with uplo = 'U' or 'u', the leading n by n - ++ upper triangular part of the array C must contain the upper - ++ triangular part of the symmetric matrix and the strictly - ++ lower triangular part of C is not referenced. On exit, the - ++ upper triangular part of the array C is overwritten by the - ++ upper triangular part of the updated matrix. - ++ Before entry with uplo = 'L' or 'l', the leading n by n - ++ lower triangular part of the array C must contain the lower - ++ triangular part of the symmetric matrix and the strictly - ++ upper triangular part of C is not referenced. On exit, the - ++ lower triangular part of the array C is overwritten by the - ++ lower triangular part of the updated matrix. - ++ \item{ldc}: on entry, specifies the first dimension of C as declared - ++ in the calling (sub) program. ldc must be at least - ++ max( 1, n ). Unchanged on exit. - ++ \end{items} - - syr2k: (CHAR,CHAR,R,M,M,R,M) -> Void - ++ syr2k(uplo,trans,alpha,A,B,beta,C) performs one - ++ of the symmetric rank 2k operations - ++ C := alpha*A*B' + alpha*B*A' + beta*C, or - ++ C := alpha*A'*B + alpha*B'*A + beta*C, - ++ where alpha and beta are scalars, C is an n by n symmetric matrix - ++ and A and B are n by k matrices in the first case and k by n - ++ matrices in the second case. - ++ Parameters: - ++ \begin{items} - ++ \item{uplo}: on entry, specifies whether the upper or lower - ++ triangular part of the array C is to be referenced as - ++ follows: - ++ uplo = 'U' or 'u' Only the upper triangular part of C - ++ is to be referenced. - ++ uplo = 'L' or 'l' Only the lower triangular part of C - ++ is to be referenced. - ++ Unchanged on exit. - ++ \item{trans}: on entry, specifies the operation to be performed as - ++ follows: - ++ trans = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + beta*C. - ++ trans = 'T' or 't' C := alpha*A'*B + alpha*B'*A + beta*C. - ++ Unchanged on exit. - ++ \item{alpha}: on entry, specifies the scalar alpha. - ++ Unchanged on exit. - ++ \item{A}: before entry with trans = 'N' or 'n', the leading n by k - ++ part of the array A must contain the matrix A, otherwise - ++ the leading k by n part of the array A must contain the - ++ matrix A. Unchanged on exit. - ++ \item{B}: before entry with trans = 'N' or 'n', the leading n by k - ++ part of the array B must contain the matrix B, otherwise - ++ the leading k by n part of the array B must contain the - ++ matrix B. Unchanged on exit. - ++ \item{beta}: on entry, specifies the scalar beta. Unchanged on exit. - ++ \item{C}: before entry with uplo = 'U' or 'u', the leading n by n - ++ upper triangular part of the array C must contain the upper - ++ triangular part of the symmetric matrix and the strictly - ++ lower triangular part of C is not referenced. On exit, the - ++ upper triangular part of the array C is overwritten by the - ++ upper triangular part of the updated matrix. - ++ Before entry with uplo = 'L' or 'l', the leading n by n - ++ lower triangular part of the array C must contain the lower - ++ triangular part of the symmetric matrix and the strictly - ++ upper triangular part of C is not referenced. On exit, the - ++ lower triangular part of the array C is overwritten by the - ++ lower triangular part of the updated matrix. - ++ \end{items} - - Implementation == add - - gemm(transa:CHAR,transb:CHAR,m:SI,n:SI,k:SI,alpha:R,A:M,lda:SI,B:M,ldb:SI,beta:R,C:M,ldc:SI): Void == - DGEMM(transa,transb,m,n,k,alpha,A,lda,B,ldb,beta,C,ldc)$Lisp - - gemm(transa:CHAR,transb:CHAR,alpha:R,A:M,B:M,beta:R,C:M): Void == - nra := nrows(A)::SI - nca := ncols(A)::SI - ldb := nrows(B)::SI - ldc := nrows(C)::SI - if transa = char "N" then - ldc < nra => error "gemm: nrows(C) must be at least nrows(A)" - if transb = char "N" then - ncopb := ncols(B)::SI - ldb < nca => error "gemm: nrows(B) must be at least ncols(A)" - ncols(C) < ncopb => error "gemm: ncols(C) must be at least ncols(B)" - DGEMM(transa,transb,nra,ncopb,nca,alpha,A,nra,B,ldb,beta,C,ldc)$Lisp - else if transb = char "T" then - ncols(B) < nca => error "gemm: ncols(B) must be at least ncols(A)" - ncols(C) < ldb => error "gemm: ncols(C) must be at least nrows(B)" - DGEMM(transa,transb,nra,ldb,nca,alpha,A,nra,B,ldb,beta,C,ldc)$Lisp - else - error "gemm: transb must be N or T" - else if transa = char "T" then - ldc < nca => error "gemm: nrows(C) must be at least ncols(A)" - if transb = char "N" then - ncopb := ncols(B)::SI - ldb < nra => error "gemm: nrows(B) must be at least nrows(A)" - ncols(C) < ncopb => error "gemm: ncols(C) must be at least ncols(B)" - DGEMM(transa,transb,nca,ncopb,nra,alpha,A,nra,B,ldb,beta,C,ldc)$Lisp - else if transb = char "T" then - ncols(B) < nra => error "gemm: ncols(B) must be at least ncols(A)" - ncols(C) < ldb => error "gemm: ncols(C) must be at least nrows(B)" - DGEMM(transa,transb,nca,ldb,nra,alpha,A,nra,B,ldb,beta,C,ldc)$Lisp - else - error "gemm: transb must be N or T" - else - error "gemm: transa must be N or T" - - symm(side:CHAR,uplo:CHAR,m:SI,n:SI,alpha:R,A:M,lda:SI,B:M,ldb:SI,beta:R,C:M,ldc:SI): Void == - DSYMM(side,uplo,m,n,alpha,A,lda,B,ldb,beta,C,ldc)$Lisp - - symm(side:CHAR,uplo:CHAR,alpha:R,A:M,B:M,beta:R,C:M): Void == - uplo ~= char "u" and uplo ~= char "U" and uplo ~= char "l" and uplo ~= char "L" - => error "symm: uplo must be one of the following values: u, U, l or L" - if side = char "l" or side = char "L" then - m := nrows(A)::SI; - n := ncols(B)::SI; - ncols(A) < m => error "symm: ncols(A) must be at least nrows(A)" - (ldb := nrows(B)::SI) < m => error "symm: nrows(B) must be at least nrows(A)" - (ldc := nrows(C)::SI) < m => error "symm: nrows(C) must be at least nrows(A)" - ncols(C) < n => error "symm: ncols(C) must be at least ncols(B)" - DSYMM(side,uplo,m,n,alpha,A,m,B,ldb,beta,C,ldc)$Lisp - else if side = char "r" or side = char "R" then - n := ncols(A)::SI; - m := nrows(B)::SI; - nrows(A) < n => error "symm: nrows(A) must be at least ncols(A)" - ncols(B) < n => error "symm: ncols(B) must be at least ncols(A)" - (ldc := nrows(C)::SI) < m => error "symm: nrows(C) must be at least nrows(B)" - ncols(C) < n => error "symm: ncols(C) must be at least ncols(A)" - DSYMM(side,uplo,m,n,alpha,A,n,B,m,beta,C,ldc)$Lisp - else - error "symm: side must be one of the following values: l, L, r or R" - - syrk(uplo:CHAR,trans:CHAR,n:SI,k:SI,alpha:R,A:M,lda:SI,beta:R,C:M,ldc:SI): Void == - DSYRK(uplo,trans,n,k,alpha,A,lda,beta,C,ldc)$Lisp - - syrk(uplo:CHAR,trans:CHAR,alpha:R,A:M,beta:R,C:M): Void == - nra := nrows(A)::SI - nca := ncols(A)::SI - uplo ~= char "u" and uplo ~= char "U" and uplo ~= char "l" and uplo ~= char "L" - => error "syrk: uplo must be one of the following values: u, U, l or L" - if trans = char "n" or trans = char "N" then - (ldc := nrows(C)::SI) < nra => error "syrk: nrows(C) must be at least nrows(A)" - ncols(C) < nra => error "syrk: ncols(C) must be at least nrows(A)" - DSYRK(uplo,trans,nra,nca,alpha,A,nra,beta,C,ldc)$Lisp - else if trans = char "t" or trans = char "T" then - (ldc := nrows(C)::SI) < nca => error "syrk: nrows(C) must be at least ncols(A)" - ncols(C) < nca => error "syrk: ncols(C) must be at least ncols(A)" - DSYRK(uplo,trans,nca,nra,alpha,A,nra,beta,C,ldc)$Lisp - else - error "syrk: trans must be one of the following values: n, N, t or T" - - syr2k(uplo:CHAR,trans:CHAR,n:SI,k:SI,alpha:R,A:M,lda:SI,B:M,ldb:SI,beta:R,C:M,ldc:SI): Void == - DSYR2K(uplo,trans,n,k,alpha,A,lda,B,ldb,beta,C,ldc)$Lisp - - syr2k(uplo:CHAR,trans:CHAR,alpha:R,A:M,B:M,beta:R,C:M): Void == - nra := nrows(A)::SI - nca := ncols(A)::SI - uplo ~= char "u" and uplo ~= char "U" and uplo ~= char "l" and uplo ~= char "L" - => error "syr2k: uplo must be one of the following values: u, U, l or L" - if trans = char "n" or trans = char "N" then - (ldb := nrows(B)::SI) < nra => error "syr2k: nrows(B) must be at least nrows(A)" - ncols(B) < nca => error "syr2k: ncols(B) must be at least ncols(A)" - (ldc := nrows(C)::SI) < nra => error "syr2k: nrows(C) must be at least nrows(A)" - ncols(C) < nra => error "syr2k: ncols(C) must be at least nrows(A)" - DSYR2K(uplo,trans,nra,nca,alpha,A,nra,B,ldb,beta,C,ldc)$Lisp - else if trans = char "t" or trans = char "T" then - (ldb := nrows(B)::SI) < nra => error "syr2k: nrows(B) must be at least nrows(A)" - ncols(B) < nca => error "syr2k: ncols(B) must be at least ncols(A)" - (ldc := nrows(C)::SI) < nca => error "syr2k: nrows(C) must be at least ncols(A)" - ncols(C) < nca => error "syr2k: ncols(C) must be at least ncols(A)" - DSYR2K(uplo,trans,nca,nra,alpha,A,nra,B,ldb,beta,C,ldc)$Lisp - else - error "syr2k: trans must be one of the following values: n, N, t or T" +\section{lsame BLAS} +%\pagehead{lsame}{lsame} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} +<>= +(defun lsame (ca cb) + (declare (type (simple-array character (*)) cb ca)) + (f2cl-lib:with-multi-array-data + ((ca character ca-%data% ca-%offset%) + (cb character cb-%data% cb-%offset%)) + (prog ((inta 0) (intb 0) (zcode 0) (lsame nil)) + (declare (type (member t nil) lsame) + (type fixnum zcode intb inta)) + (setf lsame (coerce (f2cl-lib:fstring-= ca cb) '(member t nil))) + (unless lsame + (setf zcode (f2cl-lib:ichar "Z")) + (setf inta (f2cl-lib:ichar ca)) + (setf intb (f2cl-lib:ichar cb)) + (cond + ((or (= zcode 90) (= zcode 122)) + (if (and (>= inta 97) (<= inta 122)) + (setf inta (f2cl-lib:int-sub inta 32))) + (if (and (>= intb 97) (<= intb 122)) + (setf intb (f2cl-lib:int-sub intb 32)))) + ((or (= zcode 233) (= zcode 169)) + (if + (or (and (>= inta 129) (<= inta 137)) + (and (>= inta 145) (<= inta 153)) + (and (>= inta 162) (<= inta 169))) + (setf inta (f2cl-lib:int-add inta 64))) + (if + (or (and (>= intb 129) (<= intb 137)) + (and (>= intb 145) (<= intb 153)) + (and (>= intb 162) (<= intb 169))) + (setf intb (f2cl-lib:int-add intb 64)))) + ((or (= zcode 218) (= zcode 250)) + (if (and (>= inta 225) (<= inta 250)) + (setf inta (f2cl-lib:int-sub inta 32))) + (if (and (>= intb 225) (<= intb 250)) + (setf intb (f2cl-lib:int-sub intb 32))))) + (setf lsame (coerce (= inta intb) '(member t nil)))) + (return (values lsame nil nil))))) -@ -<>= -"BLAS3" [color="#FF4488",href="bookvol10.4.pdf#nameddest=BLAS3"] -"FS" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FS"] -"ACF" [color="#4488FF",href="bookvol10.2.pdf#nameddest=ACF"] -"BLAS3" -> "FS" -"BLAS3" -> "ACF" +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::lsame fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1))) +; :return-values '(nil nil) +; :calls 'nil))) @ - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{package LAPACK Lapack} -\pagehead{Lapack}{LAPACK} -%\pagepic{ps/v104lapack.ps}{LAPACK}{1.00} - -{\bf Exports:}\\ -\begin{tabular}{lllll} -\cross{LAPACK}{?**?} & -\end{tabular} - -<>= -)abbrev package LAPACK Lapack -++ Author: Gregory Vanuxem -++ Date Created: 2006 -++ Date Last Updated: Nov 11, 2006 -++ Basic Operations: -++ Related Domains: ColumnMajorTwoDimensionnalArray -++ Also See: -++ AMS Classifications: -++ Keywords: -++ Examples: -++ References: -++ Description: -++ This package provides an interface to the -++ LAPack library --- TODO: "at least" verification -Lapack(Row,Col,M) : Exports == Implementation where - - R ==> DoubleFloat - SI ==> SingleInteger - CHAR ==> Character - VSI ==> Vector(SI) -- Vector has contiguousStorage - VSF ==> Vector(R) -- Vector has contiguousStorage - Row : OneDimensionalArrayAggregate(R) with contiguousStorage - Col : OneDimensionalArrayAggregate(R) with contiguousStorage - M : ColumnMajorTwoDimensionalArrayCategory(R,Row,Col) - - Exports == with - - getrf: (SI,SI,M,SI,VSI) -> SI - ++ gemm(transa,transb,m,n,k,alpha,A,lda,B,ldb,beta,C,ldc) performs one - ++ of the matrix-matrix operations - - getri: (SI,M,SI,VSI,VSF,SI) -> SI - ++ gemm(transa,transb,m,n,k,alpha,A,lda,B,ldb,beta,C,ldc) performs one - ++ of the matrix-matrix operations - - Implementation == add - - getrf(m:SI,n:SI,A:M,lda:SI,ipiv:VSI): SI == - DGETRF(m,n,A,lda,ipiv)$Lisp +\section{xerbla BLAS} +%\pagehead{xerbla}{xerbla} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - getri(n:SI,A:M,lda:SI,ipiv:VSI,work:VSF,lwork:SI): SI == - DGETRI(n,A,lda,ipiv,work,lwork)$Lisp +<>= +(defun xerbla (srname info) + (declare (type fixnum info) + (type (simple-array character (*)) srname)) + (f2cl-lib:with-multi-array-data + ((srname character srname-%data% srname-%offset%)) + (prog () + (declare) + (format t + " ** On entry to ~a parameter number ~a had an illegal value~%" + srname info) + (return (values nil nil))))) -@ -<>= -"LAPACK" [color="#FF4488",href="bookvol10.4.pdf#nameddest=LAPACK"] -"FS" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FS"] -"ACF" [color="#4488FF",href="bookvol10.2.pdf#nameddest=ACF"] -"LAPACK" -> "FS" -"LAPACK" -> "ACF" +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::xerbla +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (6)) +; fixnum) +; :return-values '(nil nil) +; :calls 'nil))) @ - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter A} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter B} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter C} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter D} +\chapter{BLAS Level 1} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dasum BLAS} -\pagehead{dasum}{dasum} +%\pagehead{dasum}{dasum} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} Computes doublefloat $asum \leftarrow ||re(x)||_1 + ||im(x)||_1$ @@ -1997,7 +565,7 @@ Return values are: @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{daxpy BLAS} -\pagehead{daxpy}{daxpy} +%\pagehead{daxpy}{daxpy} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} Computes doublefloat $y \leftarrow \alpha{}x + y$ @@ -2093,8 +661,20777 @@ Return values are: @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dcopy BLAS} +%\pagehead{dcopy}{dcopy} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun dcopy (n dx incx dy incy) + (declare (type (array double-float (*)) dy dx) + (type fixnum incy incx n)) + (f2cl-lib:with-multi-array-data + ((dx double-float dx-%data% dx-%offset%) + (dy double-float dy-%data% dy-%offset%)) + (prog ((i 0) (ix 0) (iy 0) (m 0) (mp1 0)) + (declare (type fixnum mp1 m iy ix i)) + (if (<= n 0) (go end_label)) + (if (and (= incx 1) (= incy 1)) (go label20)) + (setf ix 1) + (setf iy 1) + (if (< incx 0) + (setf ix + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) + 1))) + (if (< incy 0) + (setf iy + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) + 1))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%) + (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%)) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (go end_label) + label20 + (setf m (mod n 7)) + (if (= m 0) (go label40)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%) + (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)))) + (if (< n 7) (go end_label)) + label40 + (setf mp1 (f2cl-lib:int-add m 1)) + (f2cl-lib:fdo (i mp1 (f2cl-lib:int-add i 7)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%) + (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)) + (setf (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + dy-%offset%) + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + dx-%offset%)) + (setf (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 2)) + ((1 *)) + dy-%offset%) + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 2)) + ((1 *)) + dx-%offset%)) + (setf (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 3)) + ((1 *)) + dy-%offset%) + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 3)) + ((1 *)) + dx-%offset%)) + (setf (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 4)) + ((1 *)) + dy-%offset%) + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 4)) + ((1 *)) + dx-%offset%)) + (setf (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 5)) + ((1 *)) + dy-%offset%) + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 5)) + ((1 *)) + dx-%offset%)) + (setf (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 6)) + ((1 *)) + dy-%offset%) + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 6)) + ((1 *)) + dx-%offset%)))) + end_label + (return (values nil nil nil nil nil))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dcopy fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil) +; :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ddot BLAS} +%\pagehead{ddot}{ddot} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun ddot (n dx incx dy incy) + (declare (type (array double-float (*)) dy dx) + (type fixnum incy incx n)) + (f2cl-lib:with-multi-array-data + ((dx double-float dx-%data% dx-%offset%) + (dy double-float dy-%data% dy-%offset%)) + (prog ((i 0) (ix 0) (iy 0) (m 0) (mp1 0) (dtemp 0.0) (ddot 0.0)) + (declare (type (double-float) ddot dtemp) + (type fixnum mp1 m iy ix i)) + (setf ddot 0.0) + (setf dtemp 0.0) + (if (<= n 0) (go end_label)) + (if (and (= incx 1) (= incy 1)) (go label20)) + (setf ix 1) + (setf iy 1) + (if (< incx 0) + (setf ix + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) + 1))) + (if (< incy 0) + (setf iy + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) + 1))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf dtemp + (+ dtemp + (* (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%) + (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (setf ddot dtemp) + (go end_label) + label20 + (setf m (mod n 5)) + (if (= m 0) (go label40)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf dtemp + (+ dtemp + (* (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) + (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%)))))) + (if (< n 5) (go label60)) + label40 + (setf mp1 (f2cl-lib:int-add m 1)) + (f2cl-lib:fdo (i mp1 (f2cl-lib:int-add i 5)) + ((> i n) nil) + (tagbody + (setf dtemp + (+ dtemp + (* (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) + (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%)) + (* + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + dx-%offset%) + (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + dy-%offset%)) + (* + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 2)) + ((1 *)) + dx-%offset%) + (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 2)) + ((1 *)) + dy-%offset%)) + (* + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 3)) + ((1 *)) + dx-%offset%) + (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 3)) + ((1 *)) + dy-%offset%)) + (* + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 4)) + ((1 *)) + dx-%offset%) + (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 4)) + ((1 *)) + dy-%offset%)))))) + label60 + (setf ddot dtemp) + end_label + (return (values ddot nil nil nil nil nil))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::ddot fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil) +; :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dnrm2 BLAS} +%\pagehead{dnrm2}{dnrm2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0) (zero 0.0)) + (declare (type (double-float 1.0 1.0) one) + (type (double-float 0.0 0.0) zero)) + (defun dnrm2 (n x incx) + (declare (type (array double-float (*)) x) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((x double-float x-%data% x-%offset%)) + (prog ((absxi 0.0) (norm 0.0) (scale 0.0) (ssq 0.0) (ix 0) (dnrm2 0.0)) + (declare (type fixnum ix) + (type (double-float) absxi norm scale ssq dnrm2)) + (cond + ((or (< n 1) (< incx 1)) + (setf norm zero)) + ((= n 1) + (setf norm (abs (f2cl-lib:fref x-%data% (1) ((1 *)) x-%offset%)))) + (t + (setf scale zero) + (setf ssq one) + (f2cl-lib:fdo (ix 1 (f2cl-lib:int-add ix incx)) + ((> ix + (f2cl-lib:int-add 1 + (f2cl-lib:int-mul + (f2cl-lib:int-add n + (f2cl-lib:int-sub + 1)) + incx))) + nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (ix) ((1 *))) zero) + (setf absxi + (abs + (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%))) + (cond + ((< scale absxi) + (setf ssq (+ one (* ssq (expt (/ scale absxi) 2)))) + (setf scale absxi)) + (t + (setf ssq (+ ssq (expt (/ absxi scale) 2))))))))) + (setf norm (* scale (f2cl-lib:fsqrt ssq))))) + (setf dnrm2 norm) + end_label + (return (values dnrm2 nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dnrm2 fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil) +; :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{drotg BLAS} +%\pagehead{drotg}{drotg} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +Double precision. Computes plane rotation. +Arguments are: +\begin{itemize} +\item da - double-float +\item db - double-float +\item c - double-float +\item s - double-float +\end{itemize} +Returns multiple values where: +\begin{itemize} +\item 1 da - double-float +\item 2 db - double-float +\item 3 c - double-float +\item 4 s - double-float +\end{itemize} + +<>= +(defun drotg (da db c s) + (declare (type (double-float) s c db da)) + (prog ((roe 0.0) (scale 0.0) (r 0.0) (z 0.0)) + (declare (type (double-float) z r scale roe)) + (setf roe db) + (when (> (the double-float (abs da)) (the double-float (abs db))) + (setf roe da)) + (setf scale (+ (the double-float (abs da)) (the double-float (abs db)))) + (if (/= scale 0.0) (go label10)) + (setf c 1.0) + (setf s 0.0) + (setf r 0.0) + (setf z 0.0) + (go label20) + label10 + (setf r + (* scale (f2cl-lib:dsqrt (+ (expt (/ da scale) 2) (expt (/ db scale) 2))))) + (setf r (* (f2cl-lib:dsign 1.0 roe) r)) + (setf c (/ da r)) + (setf s (/ db r)) + (setf z 1.0) + (when (> (the double-float (abs da)) (the double-float (abs db))) + (setf z s)) + (if (and (>= (the double-float (abs db)) (the double-float (abs da))) + (/= c 0.0)) + (setf z (/ 1.0 c))) + label20 + (setf da r) + (setf db z) + (return (values da db c s)))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::drotg fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((double-float) (double-float) (double-float) +; (double-float)) +; :return-values '(fortran-to-lisp::da fortran-to-lisp::db +; fortran-to-lisp::c fortran-to-lisp::s) +; :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{drot BLAS} +%\pagehead{drot}{drot} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun drot (n dx incx dy incy c s) + (declare (type (double-float) s c) + (type (array double-float (*)) dy dx) + (type fixnum incy incx n)) + (f2cl-lib:with-multi-array-data + ((dx double-float dx-%data% dx-%offset%) + (dy double-float dy-%data% dy-%offset%)) + (prog ((i 0) (ix 0) (iy 0) (dtemp 0.0)) + (declare (type (double-float) dtemp) (type fixnum iy ix i)) + (if (<= n 0) (go end_label)) + (if (and (= incx 1) (= incy 1)) (go label20)) + (setf ix 1) + (setf iy 1) + (if (< incx 0) + (setf ix + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) + 1))) + (if (< incy 0) + (setf iy + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) + 1))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf dtemp + (+ (* c (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%)) + (* s (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%)))) + (setf (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%) + (- (* c (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%)) + (* s (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%)))) + (setf (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%) dtemp) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (go end_label) + label20 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf dtemp + (+ (* c (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)) + (* s (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%)))) + (setf (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%) + (- (* c (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%)) + (* s (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)))) + (setf (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) dtemp))) + end_label + (return (values nil nil nil nil nil nil nil))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::drot fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (double-float) +; (double-float)) +; :return-values '(nil nil nil nil nil nil nil) +; :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dscal BLAS} +%\pagehead{dscal}{dscal} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun dscal (n da dx incx) + (declare (type (array double-float (*)) dx) + (type (double-float) da) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((dx double-float dx-%data% dx-%offset%)) + (prog ((i 0) (m 0) (mp1 0) (nincx 0)) + (declare (type fixnum nincx mp1 m i)) + (if (or (<= n 0) (<= incx 0)) (go end_label)) + (if (= incx 1) (go label20)) + (setf nincx (f2cl-lib:int-mul n incx)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i incx)) + ((> i nincx) nil) + (tagbody + (setf (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) + (* da (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%))))) + (go end_label) + label20 + (setf m (mod n 5)) + (if (= m 0) (go label40)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) + (* da (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%))))) + (if (< n 5) (go end_label)) + label40 + (setf mp1 (f2cl-lib:int-add m 1)) + (f2cl-lib:fdo (i mp1 (f2cl-lib:int-add i 5)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) + (* da (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%))) + (setf (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + dx-%offset%) + (* da + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + dx-%offset%))) + (setf (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 2)) + ((1 *)) + dx-%offset%) + (* da + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 2)) + ((1 *)) + dx-%offset%))) + (setf (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 3)) + ((1 *)) + dx-%offset%) + (* da + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 3)) + ((1 *)) + dx-%offset%))) + (setf (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 4)) + ((1 *)) + dx-%offset%) + (* da + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 4)) + ((1 *)) + dx-%offset%))))) + end_label + (return (values nil nil nil nil))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dscal fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum (double-float) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil) +; :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dswap BLAS} +%\pagehead{dswap}{dswap} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun dswap (n dx incx dy incy) + (declare (type (array double-float (*)) dy dx) + (type fixnum incy incx n)) + (f2cl-lib:with-multi-array-data + ((dx double-float dx-%data% dx-%offset%) + (dy double-float dy-%data% dy-%offset%)) + (prog ((i 0) (ix 0) (iy 0) (m 0) (mp1 0) (dtemp 0.0)) + (declare (type (double-float) dtemp) + (type fixnum mp1 m iy ix i)) + (if (<= n 0) (go end_label)) + (if (and (= incx 1) (= incy 1)) (go label20)) + (setf ix 1) + (setf iy 1) + (if (< incx 0) + (setf ix + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) + 1))) + (if (< incy 0) + (setf iy + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) + 1))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf dtemp (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%)) + (setf (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%) + (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%)) + (setf (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%) dtemp) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (go end_label) + label20 + (setf m (mod n 3)) + (if (= m 0) (go label40)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf dtemp (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)) + (setf (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) + (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%)) + (setf (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%) dtemp))) + (if (< n 3) (go end_label)) + label40 + (setf mp1 (f2cl-lib:int-add m 1)) + (f2cl-lib:fdo (i mp1 (f2cl-lib:int-add i 3)) + ((> i n) nil) + (tagbody + (setf dtemp (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)) + (setf (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) + (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%)) + (setf (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%) dtemp) + (setf dtemp + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + dx-%offset%)) + (setf (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + dx-%offset%) + (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + dy-%offset%)) + (setf (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 1)) + ((1 *)) + dy-%offset%) + dtemp) + (setf dtemp + (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 2)) + ((1 *)) + dx-%offset%)) + (setf (f2cl-lib:fref dx-%data% + ((f2cl-lib:int-add i 2)) + ((1 *)) + dx-%offset%) + (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 2)) + ((1 *)) + dy-%offset%)) + (setf (f2cl-lib:fref dy-%data% + ((f2cl-lib:int-add i 2)) + ((1 *)) + dy-%offset%) + dtemp))) + end_label + (return (values nil nil nil nil nil))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dswap fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil) +; :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dzasum BLAS} +%\pagehead{dzasum}{dzasum} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +Computes (complex double-float) $asum \leftarrow ||re(x)||_1 + ||im(x)||_1$ + +Arguments are: +\begin{itemize} +\item n - fixnum +\item dx - array (complex double-float) +\item incx - fixnum +\end{itemize} + +Return values are: +\begin{itemize} +\item 1 nil +\item 2 nil +\item 3 nil +\end{itemize} + +<>= +(defun dzasum (n zx incx) + (declare (type (array (complex double-float) (*)) zx) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((zx (complex double-float) zx-%data% zx-%offset%)) + (prog ((i 0) (ix 0) (stemp 0.0) (dzasum 0.0)) + (declare (type (double-float) dzasum stemp) + (type fixnum ix i)) + (setf dzasum 0.0) + (setf stemp 0.0) + (if (or (<= n 0) (<= incx 0)) (go end_label)) + (if (= incx 1) (go label20)) + (setf ix 1) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf stemp + (+ stemp + (dcabs1 + (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (setf dzasum stemp) + (go end_label) + label20 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf stemp + (+ stemp + (dcabs1 + (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%)))))) + (setf dzasum stemp) + end_label + (return (values dzasum nil nil nil))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dzasum +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil) +; :calls '(fortran-to-lisp::dcabs1)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dznrm2 BLAS} +%\pagehead{dznrm2}{dznrm2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0) (zero 0.0)) + (declare (type (double-float 1.0 1.0) one) + (type (double-float 0.0 0.0) zero)) + (defun dznrm2 (n x incx) + (declare (type (array (complex double-float) (*)) x) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((x (complex double-float) x-%data% x-%offset%)) + (prog ((norm 0.0) (scale 0.0) (ssq 0.0) (temp 0.0) (ix 0) (dznrm2 0.0)) + (declare (type fixnum ix) + (type (double-float) norm scale ssq temp dznrm2)) + (cond + ((or (< n 1) (< incx 1)) + (setf norm zero)) + (t + (setf scale zero) + (setf ssq one) + (f2cl-lib:fdo (ix 1 (f2cl-lib:int-add ix incx)) + ((> ix + (f2cl-lib:int-add 1 + (f2cl-lib:int-mul + (f2cl-lib:int-add n + (f2cl-lib:int-sub 1)) + incx))) + nil) + (tagbody + (cond + ((/= + (coerce (realpart (f2cl-lib:fref x (ix) ((1 *)))) 'double-float) + zero) + (setf temp + (abs + (coerce (realpart + (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%)) + 'double-float))) + (cond + ((< scale temp) + (setf ssq (+ one (* ssq (expt (/ scale temp) 2)))) + (setf scale temp)) + (t + (setf ssq (+ ssq (expt (/ temp scale) 2))))))) + (cond + ((/= (f2cl-lib:dimag (f2cl-lib:fref x (ix) ((1 *)))) zero) + (setf temp + (abs + (f2cl-lib:dimag + (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%)))) + (cond + ((< scale temp) + (setf ssq (+ one (* ssq (expt (/ scale temp) 2)))) + (setf scale temp)) + (t + (setf ssq (+ ssq (expt (/ temp scale) 2))))))))) + (setf norm (* scale (f2cl-lib:fsqrt ssq))))) + (setf dznrm2 norm) + end_label + (return (values dznrm2 nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dznrm2 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil) +; :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{icamax BLAS} +%\pagehead{icamax}{icamax} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun icamax (n cx incx) + (declare (type (array (complex single-float) (*)) cx) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((cx (complex single-float) cx-%data% cx-%offset%)) + (labels ((cabs1 (zdum) + (+ (abs (coerce (realpart zdum) 'single-float)) + (abs (f2cl-lib:aimag zdum))))) + (declare (ftype (function (complex single-float) + (values single-float &rest t)) + cabs1)) + (prog ((zdum #C(0.0f0 0.0f0)) (i 0) (ix 0) (smax 0.0f0) (icamax 0)) + (declare (type (single-float) smax) + (type fixnum icamax ix i) + (type (complex single-float) zdum)) + (setf icamax 0) + (if (or (< n 1) (<= incx 0)) (go end_label)) + (setf icamax 1) + (if (= n 1) (go end_label)) + (if (= incx 1) (go label20)) + (setf ix 1) + (setf smax (cabs1 (f2cl-lib:fref cx-%data% (1) ((1 *)) cx-%offset%))) + (setf ix (f2cl-lib:int-add ix incx)) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (if + (<= (cabs1 (f2cl-lib:fref cx-%data% (ix) ((1 *)) cx-%offset%)) + smax) + (go label5)) + (setf icamax i) + (setf smax + (cabs1 (f2cl-lib:fref cx-%data% (ix) ((1 *)) cx-%offset%))) + label5 + (setf ix (f2cl-lib:int-add ix incx)))) + (go end_label) + label20 + (setf smax (cabs1 (f2cl-lib:fref cx-%data% (1) ((1 *)) cx-%offset%))) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (if + (<= (cabs1 (f2cl-lib:fref cx-%data% (i) ((1 *)) cx-%offset%)) + smax) + (go label30)) + (setf icamax i) + (setf smax + (cabs1 (f2cl-lib:fref cx-%data% (i) ((1 *)) cx-%offset%))) + label30)) + end_label + (return (values icamax nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::icamax +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum +; (array (complex single-float) (*)) +; fixnum) +; :return-values '(nil nil nil) +; :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{idamax BLAS} +%\pagehead{idamax}{idamax} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun idamax (n dx incx) + (declare (type (array double-float (*)) dx) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((dx double-float dx-%data% dx-%offset%)) + (prog ((i 0) (ix 0) (dmax 0.0) (idamax 0)) + (declare (type (double-float) dmax) + (type fixnum idamax ix i)) + (setf idamax 0) + (if (or (< n 1) (<= incx 0)) (go end_label)) + (setf idamax 1) + (if (= n 1) (go end_label)) + (if (= incx 1) (go label20)) + (setf ix 1) + (setf dmax + (the double-float (abs + (the double-float + (f2cl-lib:fref dx-%data% (1) ((1 *)) dx-%offset%))))) + (setf ix (f2cl-lib:int-add ix incx)) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (if + (<= + (the double-float (abs + (the double-float + (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%)))) + dmax) + (go label5)) + (setf idamax i) + (setf dmax + (the double-float (abs + (the double-float + (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%))))) + label5 + (setf ix (f2cl-lib:int-add ix incx)))) + (go end_label) + label20 + (setf dmax + (the double-float (abs + (the double-float + (f2cl-lib:fref dx-%data% (1) ((1 *)) dx-%offset%))))) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (if + (<= + (the double-float (abs + (the double-float + (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)))) + dmax) + (go label30)) + (setf idamax i) + (setf dmax + (the double-float (abs + (the double-float + (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%))))) + label30)) + end_label + (return (values idamax nil nil nil))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::idamax +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil) +; :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{isamax BLAS} +%\pagehead{isamax}{isamax} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun isamax (n sx incx) + (declare (type (array single-float (*)) sx) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((sx single-float sx-%data% sx-%offset%)) + (prog ((i 0) (ix 0) (smax 0.0f0) (isamax 0)) + (declare (type (single-float) smax) + (type fixnum isamax ix i)) + (setf isamax 0) + (if (or (< n 1) (<= incx 0)) (go end_label)) + (setf isamax 1) + (if (= n 1) (go end_label)) + (if (= incx 1) (go label20)) + (setf ix 1) + (setf smax (abs (f2cl-lib:fref sx-%data% (1) ((1 *)) sx-%offset%))) + (setf ix (f2cl-lib:int-add ix incx)) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (if + (<= (abs (f2cl-lib:fref sx-%data% (ix) ((1 *)) sx-%offset%)) smax) + (go label5)) + (setf isamax i) + (setf smax (abs (f2cl-lib:fref sx-%data% (ix) ((1 *)) sx-%offset%))) + label5 + (setf ix (f2cl-lib:int-add ix incx)))) + (go end_label) + label20 + (setf smax (abs (f2cl-lib:fref sx-%data% (1) ((1 *)) sx-%offset%))) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (if (<= (abs (f2cl-lib:fref sx-%data% (i) ((1 *)) sx-%offset%)) smax) + (go label30)) + (setf isamax i) + (setf smax (abs (f2cl-lib:fref sx-%data% (i) ((1 *)) sx-%offset%))) + label30)) + end_label + (return (values isamax nil nil nil))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::isamax +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum (array single-float (*)) +; fixnum) +; :return-values '(nil nil nil) +; :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{izamax BLAS} +%\pagehead{izamax}{izamax} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun izamax (n zx incx) + (declare (type (array (complex double-float) (*)) zx) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((zx (complex double-float) zx-%data% zx-%offset%)) + (prog ((i 0) (ix 0) (smax 0.0) (izamax 0)) + (declare (type (double-float) smax) + (type fixnum izamax ix i)) + (setf izamax 0) + (if (or (< n 1) (<= incx 0)) (go end_label)) + (setf izamax 1) + (if (= n 1) (go end_label)) + (if (= incx 1) (go label20)) + (setf ix 1) + (setf smax (dcabs1 (f2cl-lib:fref zx-%data% (1) ((1 *)) zx-%offset%))) + (setf ix (f2cl-lib:int-add ix incx)) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (if + (<= (dcabs1 (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%)) + smax) + (go label5)) + (setf izamax i) + (setf smax + (dcabs1 (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%))) + label5 + (setf ix (f2cl-lib:int-add ix incx)))) + (go end_label) + label20 + (setf smax (dcabs1 (f2cl-lib:fref zx-%data% (1) ((1 *)) zx-%offset%))) + (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (if + (<= (dcabs1 (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%)) smax) + (go label30)) + (setf izamax i) + (setf smax + (dcabs1 (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%))) + label30)) + end_label + (return (values izamax nil nil nil))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::izamax +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil) +; :calls '(fortran-to-lisp::dcabs1)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zaxpy BLAS} +%\pagehead{zaxpy}{zaxpy} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +Computes (complex double-float) $y \leftarrow \alpha{}x + y$ + +Arguments are: +\begin{itemize} +\item n - fixnum +\item da - (complex double-float) +\item dx - array (complex double-float) +\item incx - fixnum +\item dy - array (complex double-float) +\item incy - fixnum +\end{itemize} + +Return values are: +\begin{itemize} +\item 1 nil +\item 2 nil +\item 3 nil +\item 4 nil +\item 5 nil +\item 6 nil +\end{itemize} + +<>= +(defun zaxpy (n za zx incx zy incy) + (declare (type (array (complex double-float) (*)) zy zx) + (type (complex double-float) za) + (type fixnum incy incx n)) + (f2cl-lib:with-multi-array-data + ((zx (complex double-float) zx-%data% zx-%offset%) + (zy (complex double-float) zy-%data% zy-%offset%)) + (prog ((i 0) (ix 0) (iy 0)) + (declare (type fixnum iy ix i)) + (if (<= n 0) (go end_label)) + (if (= (dcabs1 za) 0.0) (go end_label)) + (if (and (= incx 1) (= incy 1)) (go label20)) + (setf ix 1) + (setf iy 1) + (if (< incx 0) + (setf ix + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) + 1))) + (if (< incy 0) + (setf iy + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) + 1))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref zy-%data% (iy) ((1 *)) zy-%offset%) + (+ (f2cl-lib:fref zy-%data% (iy) ((1 *)) zy-%offset%) + (* za + (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (go end_label) + label20 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%) + (+ (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%) + (* za (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%)))))) + end_label + (return (values nil nil nil nil nil nil))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zaxpy fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::dcabs1)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zcopy BLAS} +%\pagehead{zcopy}{zcopy} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun zcopy (n zx incx zy incy) + (declare (type (array (complex double-float) (*)) zy zx) + (type fixnum incy incx n)) + (f2cl-lib:with-multi-array-data + ((zx (complex double-float) zx-%data% zx-%offset%) + (zy (complex double-float) zy-%data% zy-%offset%)) + (prog ((i 0) (ix 0) (iy 0)) + (declare (type fixnum iy ix i)) + (if (<= n 0) (go end_label)) + (if (and (= incx 1) (= incy 1)) (go label20)) + (setf ix 1) + (setf iy 1) + (if (< incx 0) + (setf ix + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) + 1))) + (if (< incy 0) + (setf iy + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) + 1))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref zy-%data% (iy) ((1 *)) zy-%offset%) + (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%)) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (go end_label) + label20 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%) + (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%)))) + end_label + (return (values nil nil nil nil nil))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zcopy fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil) +; :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zdotc BLAS} +%\pagehead{zdotc}{zdotc} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun zdotc (n zx incx zy incy) + (declare (type (array (complex double-float) (*)) zy zx) + (type fixnum incy incx n)) + (f2cl-lib:with-multi-array-data + ((zx (complex double-float) zx-%data% zx-%offset%) + (zy (complex double-float) zy-%data% zy-%offset%)) + (prog ((i 0) (ix 0) (iy 0) (ztemp #C(0.0 0.0)) (zdotc #C(0.0 0.0))) + (declare (type (complex double-float) zdotc ztemp) + (type fixnum iy ix i)) + (setf ztemp (complex 0.0 0.0)) + (setf zdotc (complex 0.0 0.0)) + (if (<= n 0) (go end_label)) + (if (and (= incx 1) (= incy 1)) (go label20)) + (setf ix 1) + (setf iy 1) + (if (< incx 0) + (setf ix + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) + 1))) + (if (< incy 0) + (setf iy + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) + 1))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ztemp + (+ ztemp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%)) + (f2cl-lib:fref zy-%data% (iy) ((1 *)) zy-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (setf zdotc ztemp) + (go end_label) + label20 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ztemp + (+ ztemp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%)) + (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%)))))) + (setf zdotc ztemp) + end_label + (return (values zdotc nil nil nil nil nil))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zdotc fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil) +; :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zdotu BLAS} +%\pagehead{zdotu}{zdotu} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun zdotu (n zx incx zy incy) + (declare (type (array (complex double-float) (*)) zy zx) + (type fixnum incy incx n)) + (f2cl-lib:with-multi-array-data + ((zx (complex double-float) zx-%data% zx-%offset%) + (zy (complex double-float) zy-%data% zy-%offset%)) + (prog ((i 0) (ix 0) (iy 0) (ztemp #C(0.0 0.0)) (zdotu #C(0.0 0.0))) + (declare (type (complex double-float) zdotu ztemp) + (type fixnum iy ix i)) + (setf ztemp (complex 0.0 0.0)) + (setf zdotu (complex 0.0 0.0)) + (if (<= n 0) (go end_label)) + (if (and (= incx 1) (= incy 1)) (go label20)) + (setf ix 1) + (setf iy 1) + (if (< incx 0) + (setf ix + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) + 1))) + (if (< incy 0) + (setf iy + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) + 1))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ztemp + (+ ztemp + (* (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%) + (f2cl-lib:fref zy-%data% (iy) ((1 *)) zy-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (setf zdotu ztemp) + (go end_label) + label20 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ztemp + (+ ztemp + (* (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%) + (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%)))))) + (setf zdotu ztemp) + end_label + (return (values zdotu nil nil nil nil nil))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zdotu fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil) +; :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zdscal BLAS} +%\pagehead{zdscal}{zdscal} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun zdscal (n da zx incx) + (declare (type (array (complex double-float) (*)) zx) + (type (double-float) da) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((zx (complex double-float) zx-%data% zx-%offset%)) + (prog ((i 0) (ix 0)) + (declare (type fixnum ix i)) + (if (or (<= n 0) (<= incx 0)) (go end_label)) + (if (= incx 1) (go label20)) + (setf ix 1) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%) + (* (coerce (complex da 0.0) '(complex doublefloat)) + (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%))) + (setf ix (f2cl-lib:int-add ix incx)))) + (go end_label) + label20 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%) + (* (coerce (complex da 0.0) '(complex double-float)) + (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%))))) + end_label + (return (values nil nil nil nil))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zdscal +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum (double-float) +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil) +; :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zrotg BLAS} +%\pagehead{zrotg}{zrotg} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + + +(Complex Double-Float). Computes plane rotation. +Arguments are: +\begin{itemize} +\item da - (complex double-float) +\item db - (complex double-float) +\item c - double-float +\item s - (complex double-float) +\end{itemize} +Returns multiple values where: +\begin{itemize} +\item 1 da - ca +\item 2 db - nil +\item 3 c - c +\item 4 s - s +\end{itemize} + +<>= +(defun zrotg (ca cb c s) + (declare (type (double-float) c) (type (complex double-float) s cb ca)) + (prog ((alpha #C(0.0 0.0)) (norm 0.0) (scale 0.0)) + (declare (type (double-float) scale norm) + (type (complex double-float) alpha)) + (if (/= (f2cl-lib:cdabs ca) 0.0) (go label10)) + (setf c 0.0) + (setf s (complex 1.0 0.0)) + (setf ca cb) + (go label20) + label10 + (setf scale + (coerce (+ (f2cl-lib:cdabs ca) (f2cl-lib:cdabs cb)) 'double-float)) + (setf norm + (* scale + (f2cl-lib:dsqrt + (+ (expt (f2cl-lib:cdabs (/ ca + (coerce (complex scale 0.0) '(complex double-float)))) 2) + (expt (f2cl-lib:cdabs (/ cb + (coerce (complex scale 0.0) '(complex double-float)))) + 2))))) + (setf alpha (/ ca (f2cl-lib:cdabs ca))) + (setf c (/ (f2cl-lib:cdabs ca) norm)) + (setf s (/ (* alpha (f2cl-lib:dconjg cb)) norm)) + (setf ca (* alpha norm)) + label20 + (return (values ca nil c s)))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zrotg fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(((complex double-float)) +; ((complex double-float)) (double-float) +; ((complex double-float))) +; :return-values '(fortran-to-lisp::ca nil fortran-to-lisp::c +; fortran-to-lisp::s) +; :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zscal BLAS} +%\pagehead{zscal}{zscal} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun zscal (n za zx incx) + (declare (type (array (complex double-float) (*)) zx) + (type (complex double-float) za) + (type fixnum incx n)) + (f2cl-lib:with-multi-array-data + ((zx (complex double-float) zx-%data% zx-%offset%)) + (prog ((i 0) (ix 0)) + (declare (type fixnum ix i)) + (if (or (<= n 0) (<= incx 0)) (go end_label)) + (if (= incx 1) (go label20)) + (setf ix 1) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%) + (* za (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%))) + (setf ix (f2cl-lib:int-add ix incx)))) + (go end_label) + label20 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%) + (* za (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%))))) + end_label + (return (values nil nil nil nil))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zscal fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil) +; :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zswap BLAS} +%\pagehead{zswap}{zswap} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(defun zswap (n zx incx zy incy) + (declare (type (array (complex double-float) (*)) zy zx) + (type fixnum incy incx n)) + (f2cl-lib:with-multi-array-data + ((zx (complex double-float) zx-%data% zx-%offset%) + (zy (complex double-float) zy-%data% zy-%offset%)) + (prog ((i 0) (ix 0) (iy 0) (ztemp #C(0.0 0.0))) + (declare (type (complex double-float) ztemp) + (type fixnum iy ix i)) + (if (<= n 0) (go end_label)) + (if (and (= incx 1) (= incy 1)) (go label20)) + (setf ix 1) + (setf iy 1) + (if (< incx 0) + (setf ix + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) + 1))) + (if (< incy 0) + (setf iy + (f2cl-lib:int-add + (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) + 1))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ztemp (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%)) + (setf (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%) + (f2cl-lib:fref zy-%data% (iy) ((1 *)) zy-%offset%)) + (setf (f2cl-lib:fref zy-%data% (iy) ((1 *)) zy-%offset%) ztemp) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (go end_label) + label20 + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ztemp (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%)) + (setf (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%) + (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%)) + (setf (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%) ztemp))) + end_label + (return (values nil nil nil nil nil))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zswap fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil) +; :calls 'nil))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{BLAS Level 2} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgbmv BLAS} +%\pagehead{dgbmv}{dgbmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0) (zero 0.0)) + (declare (type (double-float 1.0 1.0) one) + (type (double-float 0.0 0.0) zero)) + (defun dgbmv (trans m n kl ku alpha a lda x incx beta y incy) + (declare (type (array double-float (*)) y x a) + (type (double-float) beta alpha) + (type fixnum incy incx lda ku kl n m) + (type (simple-array character (*)) trans)) + (f2cl-lib:with-multi-array-data + ((trans character trans-%data% trans-%offset%) + (a double-float a-%data% a-%offset%) + (x double-float x-%data% x-%offset%) + (y double-float y-%data% y-%offset%)) + (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (k 0) (kup1 0) + (kx 0) (ky 0) (lenx 0) (leny 0) (temp 0.0)) + (declare (type fixnum i info ix iy j jx jy k kup1 kx ky + lenx leny) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 1)) + ((< m 0) + (setf info 2)) + ((< n 0) + (setf info 3)) + ((< kl 0) + (setf info 4)) + ((< ku 0) + (setf info 5)) + ((< lda (f2cl-lib:int-add kl ku 1)) + (setf info 8)) + ((= incx 0) + (setf info 10)) + ((= incy 0) + (setf info 13))) + (cond + ((/= info 0) + (xerbla "DGBMV " info) + (go end_label))) + (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one))) + (go end_label)) + (cond + ((lsame trans "N") + (setf lenx n) + (setf leny m)) + (t + (setf lenx m) + (setf leny n))) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub lenx 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub leny 1) + incy))))) + (cond + ((/= beta one) + (cond + ((= incy 1) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + zero)))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%)))))))) + (t + (setf iy ky) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + zero) + (setf iy (f2cl-lib:int-add iy incy))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%))) + (setf iy (f2cl-lib:int-add iy incy)))))))))) + (if (= alpha zero) (go end_label)) + (setf kup1 (f2cl-lib:int-add ku 1)) + (cond + ((lsame trans "N") + (setf jx kx) + (cond + ((= incy 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf k (f2cl-lib:int-sub kup1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + ku)))) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum m) + (the fixnum + (f2cl-lib:int-add j kl)))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add k i) j) + ((1 lda) (1 *)) + a-%offset%)))))))) + (setf jx (f2cl-lib:int-add jx incx))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf iy ky) + (setf k (f2cl-lib:int-sub kup1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + ku)))) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum m) + (the fixnum + (f2cl-lib:int-add j kl)))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add k i) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf iy (f2cl-lib:int-add iy incy)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (if (> j ku) (setf ky (f2cl-lib:int-add ky incy)))))))) + (t + (setf jy ky) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp zero) + (setf k (f2cl-lib:int-sub kup1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + ku)))) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum m) + (the fixnum + (f2cl-lib:int-add j kl)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add k i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp))) + (setf jy (f2cl-lib:int-add jy incy))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp zero) + (setf ix kx) + (setf k (f2cl-lib:int-sub kup1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + ku)))) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum m) + (the fixnum + (f2cl-lib:int-add j kl)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add k i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp))) + (setf jy (f2cl-lib:int-add jy incy)) + (if (> j ku) (setf kx (f2cl-lib:int-add kx incx))))))))) + end_label + (return + (values nil nil nil nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgbmv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum fixnum +; fixnum fixnum +; (double-float) (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (double-float) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil +; nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgemv BLAS} +%\pagehead{dgemv}{dgemv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0) (zero 0.0)) + (declare (type (double-float 1.0 1.0) one) + (type (double-float 0.0 0.0) zero)) + (defun dgemv (trans m n alpha a lda x incx beta y incy) + (declare (type (array double-float (*)) y x a) + (type (double-float) beta alpha) + (type fixnum incy incx lda n m) + (type (simple-array character (*)) trans)) + (f2cl-lib:with-multi-array-data + ((trans character trans-%data% trans-%offset%) + (a double-float a-%data% a-%offset%) + (x double-float x-%data% x-%offset%) + (y double-float y-%data% y-%offset%)) + (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (kx 0) (ky 0) + (lenx 0) (leny 0) (temp 0.0)) + (declare (type fixnum i info ix iy j jx jy kx ky lenx + leny) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 1)) + ((< m 0) + (setf info 2)) + ((< n 0) + (setf info 3)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info 6)) + ((= incx 0) + (setf info 8)) + ((= incy 0) + (setf info 11))) + (cond + ((/= info 0) + (xerbla "DGEMV " info) + (go end_label))) + (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one))) + (go end_label)) + (cond + ((lsame trans "N") + (setf lenx n) + (setf leny m)) + (t + (setf lenx m) + (setf leny n))) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub lenx 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub leny 1) + incy))))) + (cond + ((/= beta one) + (cond + ((= incy 1) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + zero)))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%)))))))) + (t + (setf iy ky) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + zero) + (setf iy (f2cl-lib:int-add iy incy))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%))) + (setf iy (f2cl-lib:int-add iy incy)))))))))) + (if (= alpha zero) (go end_label)) + (cond + ((lsame trans "N") + (setf jx kx) + (cond + ((= incy 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))))) + (setf jx (f2cl-lib:int-add jx incx))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf iy ky) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf iy (f2cl-lib:int-add iy incy)))))) + (setf jx (f2cl-lib:int-add jx incx))))))) + (t + (setf jy ky) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp))) + (setf jy (f2cl-lib:int-add jy incy))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp zero) + (setf ix kx) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp))) + (setf jy (f2cl-lib:int-add jy incy)))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgemv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum fixnum +; (double-float) (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (double-float) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dger BLAS} +%\pagehead{dger}{dger} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dger (m n alpha x incx y incy a lda) + (declare (type (array double-float (*)) a y x) + (type (double-float) alpha) + (type fixnum lda incy incx n m)) + (f2cl-lib:with-multi-array-data + ((x double-float x-%data% x-%offset%) + (y double-float y-%data% y-%offset%) + (a double-float a-%data% a-%offset%)) + (prog ((i 0) (info 0) (ix 0) (j 0) (jy 0) (kx 0) (temp 0.0)) + (declare (type fixnum i info ix j jy kx) + (type (double-float) temp)) + (setf info 0) + (cond + ((< m 0) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 5)) + ((= incy 0) + (setf info 7)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "DGER " info) + (go end_label))) + (if (or (= m 0) (= n 0) (= alpha zero)) (go end_label)) + (cond + ((> incy 0) + (setf jy 1)) + (t + (setf jy + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incy))))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref y (jy) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%) + temp))))))) + (setf jy (f2cl-lib:int-add jy incy))))) + (t + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub m 1) + incx))))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref y (jy) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%))) + (setf ix kx) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp))) + (setf ix (f2cl-lib:int-add ix incx)))))) + (setf jy (f2cl-lib:int-add jy incy)))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dger fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (double-float) (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dsbmv BLAS} +%\pagehead{dsbmv}{dsbmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0) (zero 0.0)) + (declare (type (double-float 1.0 1.0) one) + (type (double-float 0.0 0.0) zero)) + (defun dsbmv (uplo n k alpha a lda x incx beta y incy) + (declare (type (array double-float (*)) y x a) + (type (double-float) beta alpha) + (type fixnum incy incx lda k n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (a double-float a-%data% a-%offset%) + (x double-float x-%data% x-%offset%) + (y double-float y-%data% y-%offset%)) + (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (kplus1 0) (kx 0) + (ky 0) (l 0) (temp1 0.0) (temp2 0.0)) + (declare (type fixnum i info ix iy j jx jy kplus1 kx ky l) + (type (double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((< k 0) + (setf info 3)) + ((< lda (f2cl-lib:int-add k 1)) + (setf info 6)) + ((= incx 0) + (setf info 8)) + ((= incy 0) + (setf info 11))) + (cond + ((/= info 0) + (xerbla "DSBMV " info) + (go end_label))) + (if (or (= n 0) (and (= alpha zero) (= beta one))) (go end_label)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incy))))) + (cond + ((/= beta one) + (cond + ((= incy 1) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + zero)))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%)))))))) + (t + (setf iy ky) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + zero) + (setf iy (f2cl-lib:int-add iy incy))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%))) + (setf iy (f2cl-lib:int-add iy incy)))))))))) + (if (= alpha zero) (go end_label)) + (cond + ((lsame uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf ix kx) + (setf iy ky) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (cond + ((> j k) + (setf kx (f2cl-lib:int-add kx incx)) + (setf ky (f2cl-lib:int-add ky incy))))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf l (f2cl-lib:int-sub 1 j)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* alpha temp2)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf l (f2cl-lib:int-sub 1 j)) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)) + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dsbmv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum fixnum +; (double-float) (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (double-float) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dspmv BLAS} +%\pagehead{dspmv}{dspmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0) (zero 0.0)) + (declare (type (double-float 1.0 1.0) one) + (type (double-float 0.0 0.0) zero)) + (defun dspmv (uplo n alpha ap x incx beta y incy) + (declare (type (array double-float (*)) y x ap) + (type (double-float) beta alpha) + (type fixnum incy incx n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (ap double-float ap-%data% ap-%offset%) + (x double-float x-%data% x-%offset%) + (y double-float y-%data% y-%offset%)) + (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (k 0) (kk 0) + (kx 0) (ky 0) (temp1 0.0) (temp2 0.0)) + (declare (type fixnum i info ix iy j jx jy k kk kx ky) + (type (double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 6)) + ((= incy 0) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "DSPMV " info) + (go end_label))) + (if (or (= n 0) (and (= alpha zero) (= beta one))) (go end_label)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incy))))) + (cond + ((/= beta one) + (cond + ((= incy 1) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + zero)))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%)))))))) + (t + (setf iy ky) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + zero) + (setf iy (f2cl-lib:int-add iy incy))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%))) + (setf iy (f2cl-lib:int-add iy incy)))))))))) + (if (= alpha zero) (go end_label)) + (setf kk 1) + (cond + ((lsame uplo "U") + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf k kk) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) + (* alpha temp2))) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf ix kx) + (setf iy ky) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub 2))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-add kk 1)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* alpha temp2))) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) + (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub j))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)) + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dspmv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum (double-float) +; (array double-float (*)) (array double-float (*)) +; fixnum (double-float) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dspr2 BLAS} +%\pagehead{dspr2}{dspr2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dspr2 (uplo n alpha x incx y incy ap) + (declare (type (array double-float (*)) ap y x) + (type (double-float) alpha) + (type fixnum incy incx n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (x double-float x-%data% x-%offset%) + (y double-float y-%data% y-%offset%) + (ap double-float ap-%data% ap-%offset%)) + (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (k 0) (kk 0) + (kx 0) (ky 0) (temp1 0.0) (temp2 0.0)) + (declare (type fixnum i info ix iy j jx jy k kk kx ky) + (type (double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 5)) + ((= incy 0) + (setf info 7))) + (cond + ((/= info 0) + (xerbla "DSPR2 " info) + (go end_label))) + (if (or (= n 0) (= alpha zero)) (go end_label)) + (cond + ((or (/= incx 1) (/= incy 1)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incy))))) + (setf jx kx) + (setf jy ky))) + (setf kk 1) + (cond + ((lsame uplo "U") + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) + (/= (f2cl-lib:fref y (j) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + (setf k kk) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + temp2))) + (setf k (f2cl-lib:int-add k 1)))))) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf ix kx) + (setf iy ky) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + temp2))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) + (/= (f2cl-lib:fref y (j) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + (setf k kk) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + temp2))) + (setf k (f2cl-lib:int-add k 1)))))) + (setf kk + (f2cl-lib:int-add + (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) + 1))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub j))) + nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + temp2))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (setf kk + (f2cl-lib:int-add + (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) + 1)))))))) + end_label + (return (values nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dspr2 fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum (double-float) +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum +; (array double-float (*))) +; :return-values '(nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dspr BLAS} +%%\pagehead{dspr}{dspr} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dspr (uplo n alpha x incx ap) + (declare (type (array double-float (*)) ap x) + (type (double-float) alpha) + (type fixnum incx n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (x double-float x-%data% x-%offset%) + (ap double-float ap-%data% ap-%offset%)) + (prog ((i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0) (kk 0) (kx 0) (temp 0.0)) + (declare (type fixnum i info ix j jx k kk kx) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 5))) + (cond + ((/= info 0) + (xerbla "DSPR " info) + (go end_label))) + (if (or (= n 0) (= alpha zero)) (go end_label)) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (setf kk 1) + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + (setf k kk) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp))) + (setf k (f2cl-lib:int-add k 1)))))) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf ix kx) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp))) + (setf ix (f2cl-lib:int-add ix incx)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + (setf k kk) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp))) + (setf k (f2cl-lib:int-add k 1)))))) + (setf kk + (f2cl-lib:int-add + (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) + 1))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf ix jx) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub j))) + nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp))) + (setf ix (f2cl-lib:int-add ix incx)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk + (f2cl-lib:int-add + (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) + 1)))))))) + end_label + (return (values nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dspr fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum (double-float) +; (array double-float (*)) fixnum +; (array double-float (*))) +; :return-values '(nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dsymv BLAS} +%\pagehead{dsymv}{dsymv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0) (zero 0.0)) + (declare (type (double-float 1.0 1.0) one) + (type (double-float 0.0 0.0) zero)) + (defun dsymv (uplo n alpha a lda x incx beta y incy) + (declare (type (array double-float (*)) y x a) + (type (double-float) beta alpha) + (type fixnum incy incx lda n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (a double-float a-%data% a-%offset%) + (x double-float x-%data% x-%offset%) + (y double-float y-%data% y-%offset%)) + (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (kx 0) (ky 0) + (temp1 0.0) (temp2 0.0)) + (declare (type fixnum i info ix iy j jx jy kx ky) + (type (double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info 5)) + ((= incx 0) + (setf info 7)) + ((= incy 0) + (setf info 10))) + (cond + ((/= info 0) + (xerbla "DSYMV " info) + (go end_label))) + (if (or (= n 0) (and (= alpha zero) (= beta one))) (go end_label)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incy))))) + (cond + ((/= beta one) + (cond + ((= incy 1) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + zero)))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%)))))))) + (t + (setf iy ky) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + zero) + (setf iy (f2cl-lib:int-add iy incy))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%))) + (setf iy (f2cl-lib:int-add iy incy)))))))))) + (if (= alpha zero) (go end_label)) + (cond + ((lsame uplo "U") + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf ix kx) + (setf iy ky) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* alpha temp2)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)) + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dsymv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum (double-float) +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum +; (double-float) (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dsyr2 BLAS} +%\pagehead{dsyr2}{dsyr2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dsyr2 (uplo n alpha x incx y incy a lda) + (declare (type (array double-float (*)) a y x) + (type (double-float) alpha) + (type fixnum lda incy incx n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (x double-float x-%data% x-%offset%) + (y double-float y-%data% y-%offset%) + (a double-float a-%data% a-%offset%)) + (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (kx 0) (ky 0) + (temp1 0.0) (temp2 0.0)) + (declare (type fixnum i info ix iy j jx jy kx ky) + (type (double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 5)) + ((= incy 0) + (setf info 7)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "DSYR2 " info) + (go end_label))) + (if (or (= n 0) (= alpha zero)) (go end_label)) + (cond + ((or (/= incx 1) (/= incy 1)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incy))))) + (setf jx kx) + (setf jy ky))) + (cond + ((lsame uplo "U") + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) + (/= (f2cl-lib:fref y (j) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + temp2)))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf ix kx) + (setf iy ky) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + temp2))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) + (/= (f2cl-lib:fref y (j) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + temp2)))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + temp2))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dsyr2 fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum (double-float) +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dsyr BLAS} +%\pagehead{dsyr}{dsyr} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dsyr (uplo n alpha x incx a lda) + (declare (type (array double-float (*)) a x) + (type (double-float) alpha) + (type fixnum lda incx n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (x double-float x-%data% x-%offset%) + (a double-float a-%data% a-%offset%)) + (prog ((i 0) (info 0) (ix 0) (j 0) (jx 0) (kx 0) (temp 0.0)) + (declare (type fixnum i info ix j jx kx) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 5)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info 7))) + (cond + ((/= info 0) + (xerbla "DSYR " info) + (go end_label))) + (if (or (= n 0) (= alpha zero)) (go end_label)) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp)))))))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf ix kx) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp))) + (setf ix (f2cl-lib:int-add ix incx)))))) + (setf jx (f2cl-lib:int-add jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp)))))))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf ix jx) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp))) + (setf ix (f2cl-lib:int-add ix incx)))))) + (setf jx (f2cl-lib:int-add jx incx)))))))) + end_label + (return (values nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dsyr fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum (double-float) +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dtbmv BLAS} +%\pagehead{dtbmv}{dtbmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dtbmv (uplo trans diag n k a lda x incx) + (declare (type (array double-float (*)) x a) + (type fixnum incx lda k n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (a double-float a-%data% a-%offset%) + (x double-float x-%data% x-%offset%)) + (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (kplus1 0) (kx 0) + (l 0) (temp 0.0)) + (declare (type (member t nil) nounit) + (type fixnum i info ix j jx kplus1 kx l) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< k 0) + (setf info 5)) + ((< lda (f2cl-lib:int-add k 1)) + (setf info 7)) + ((= incx 0) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "DTBMV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%))))))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (if (> j k) (setf kx (f2cl-lib:int-add kx incx)))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub 1 j)) + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%))))))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (setf l (f2cl-lib:int-sub 1 j)) + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf jx (f2cl-lib:int-sub jx incx)) + (if (>= (f2cl-lib:int-sub n j) k) + (setf kx (f2cl-lib:int-sub kx incx)))))))))) + (t + (cond + ((lsame uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub kplus1 j)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf kx (f2cl-lib:int-sub kx incx)) + (setf ix kx) + (setf l (f2cl-lib:int-sub kplus1 j)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub 1 j)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf kx (f2cl-lib:int-add kx incx)) + (setf ix kx) + (setf l (f2cl-lib:int-sub 1 j)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dtbmv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dtbsv BLAS} +%\pagehead{dtbsv}{dtbsv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dtbsv (uplo trans diag n k a lda x incx) + (declare (type (array double-float (*)) x a) + (type fixnum incx lda k n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (a double-float a-%data% a-%offset%) + (x double-float x-%data% x-%offset%)) + (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (kplus1 0) (kx 0) + (l 0) (temp 0.0)) + (declare (type (member t nil) nounit) + (type fixnum i info ix j jx kplus1 kx l) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< k 0) + (setf info 5)) + ((< lda (f2cl-lib:int-add k 1)) + (setf info 7)) + ((= incx 0) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "DTBSV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf l (f2cl-lib:int-sub kplus1 j)) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%))))))))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf kx (f2cl-lib:int-sub kx incx)) + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf ix kx) + (setf l (f2cl-lib:int-sub kplus1 j)) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))))) + (setf jx (f2cl-lib:int-sub jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf l (f2cl-lib:int-sub 1 j)) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%))))))))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf kx (f2cl-lib:int-add kx incx)) + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf ix kx) + (setf l (f2cl-lib:int-sub 1 j)) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))))) + (setf jx (f2cl-lib:int-add jx incx))))))))) + (t + (cond + ((lsame uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)) + (if (> j k) (setf kx (f2cl-lib:int-add kx incx)))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub 1 j)) + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (setf l (f2cl-lib:int-sub 1 j)) + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx)) + (if (>= (f2cl-lib:int-sub n j) k) + (setf kx (f2cl-lib:int-sub kx incx))))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dtbsv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dtpmv BLAS} +%\pagehead{dtpmv}{dtpmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dtpmv (uplo trans diag n ap x incx) + (declare (type (array double-float (*)) x ap) + (type fixnum incx n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (ap double-float ap-%data% ap-%offset%) + (x double-float x-%data% x-%offset%)) + (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0) (kk 0) + (kx 0) (temp 0.0)) + (declare (type (member t nil) nounit) + (type fixnum i info ix j jx k kk kx) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((= incx 0) + (setf info 7))) + (cond + ((/= info 0) + (xerbla "DTPMV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (setf kk 1) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k kk) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)))))) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub + 2))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k kk) + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-sub k 1)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk n) + j)) + ((1 *)) + ap-%offset%)))))) + (setf kk + (f2cl-lib:int-sub kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (k kk + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub + (f2cl-lib:int-add + n + (f2cl-lib:int-sub + (f2cl-lib:int-add + j + 1)))))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk n) + j)) + ((1 *)) + ap-%offset%)))))) + (setf jx (f2cl-lib:int-sub jx incx)) + (setf kk + (f2cl-lib:int-sub kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))))))) + (t + (cond + ((lsame uplo "U") + (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-sub kk 1)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-sub k 1)))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp) + (setf kk (f2cl-lib:int-sub kk j))))) + (t + (setf jx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix jx) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (f2cl-lib:fdo (k + (f2cl-lib:int-add kk (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub j) + 1)) + nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx)) + (setf kk (f2cl-lib:int-sub kk j))))))) + (t + (setf kk 1) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-add kk 1)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix jx) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) + (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub j))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1))))))))))) + end_label + (return (values nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dtpmv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dtpsv BLAS} +%\pagehead{dtpsv}{dtpsv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dtpsv (uplo trans diag n ap x incx) + (declare (type (array double-float (*)) x ap) + (type fixnum incx n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (ap double-float ap-%data% ap-%offset%) + (x double-float x-%data% x-%offset%)) + (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0) (kk 0) + (kx 0) (temp 0.0)) + (declare (type (member t nil) nounit) + (type fixnum i info ix j jx k kk kx) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((= incx 0) + (setf info 7))) + (cond + ((/= info 0) + (xerbla "DTPSV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k (f2cl-lib:int-sub kk 1)) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-sub k 1)))))) + (setf kk (f2cl-lib:int-sub kk j))))) + (t + (setf jx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix jx) + (f2cl-lib:fdo (k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub + j) + 1)) + nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))))))) + (setf jx (f2cl-lib:int-sub jx incx)) + (setf kk (f2cl-lib:int-sub kk j))))))) + (t + (setf kk 1) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k (f2cl-lib:int-add kk 1)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))))) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix jx) + (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) + (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub + j))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))))))) + (t + (cond + ((lsame uplo "U") + (setf kk 1) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k kk) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub 2))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k kk) + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-sub k 1)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk n) + j)) + ((1 *)) + ap-%offset%)))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp) + (setf kk + (f2cl-lib:int-sub kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (k kk + (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub + (f2cl-lib:int-add n + (f2cl-lib:int-sub + (f2cl-lib:int-add + j + 1)))))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk n) + j)) + ((1 *)) + ap-%offset%)))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx)) + (setf kk + (f2cl-lib:int-sub kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1))))))))))) + end_label + (return (values nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dtpsv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dtrmv BLAS} +%\pagehead{dtrmv}{dtrmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dtrmv (uplo trans diag n a lda x incx) + (declare (type (array double-float (*)) x a) + (type fixnum incx lda n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (a double-float a-%data% a-%offset%) + (x double-float x-%data% x-%offset%)) + (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (kx 0) (temp 0.0)) + (declare (type (member t nil) nounit) + (type fixnum i info ix j jx kx) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info 6)) + ((= incx 0) + (setf info 8))) + (cond + ((/= info 0) + (xerbla "DTRMV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf jx (f2cl-lib:int-add jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf jx (f2cl-lib:int-sub jx incx))))))))) + (t + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix jx) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix jx) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dtrmv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dtrsv BLAS} +%\pagehead{dtrsv}{dtrsv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero 0.0)) + (declare (type (double-float 0.0 0.0) zero)) + (defun dtrsv (uplo trans diag n a lda x incx) + (declare (type (array double-float (*)) x a) + (type fixnum incx lda n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (a double-float a-%data% a-%offset%) + (x double-float x-%data% x-%offset%)) + (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (kx 0) (temp 0.0)) + (declare (type (member t nil) nounit) + (type fixnum i info ix j jx kx) + (type (double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info 6)) + ((= incx 0) + (setf info 8))) + (cond + ((/= info 0) + (xerbla "DTRSV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%))))))))))) + (t + (setf jx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix jx) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))))) + (setf jx (f2cl-lib:int-sub jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%))))))))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix jx) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))))) + (setf jx (f2cl-lib:int-add jx incx))))))))) + (t + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx)))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dtrsv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zgbmv BLAS} +%\pagehead{zgbmv}{zgbmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zgbmv (trans m n kl ku alpha a lda x incx beta y incy) + (declare (type (array (complex double-float) (*)) y x a) + (type (complex double-float) beta alpha) + (type fixnum incy incx lda ku kl n m) + (type (simple-array character (*)) trans)) + (f2cl-lib:with-multi-array-data + ((trans character trans-%data% trans-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (x (complex double-float) x-%data% x-%offset%) + (y (complex double-float) y-%data% y-%offset%)) + (prog ((noconj nil) (i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) + (k 0) (kup1 0) (kx 0) (ky 0) (lenx 0) (leny 0) (temp #C(0.0 0.0))) + (declare (type (member t nil) noconj) + (type fixnum i info ix iy j jx jy k kup1 kx ky + lenx leny) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 1)) + ((< m 0) + (setf info 2)) + ((< n 0) + (setf info 3)) + ((< kl 0) + (setf info 4)) + ((< ku 0) + (setf info 5)) + ((< lda (f2cl-lib:int-add kl ku 1)) + (setf info 8)) + ((= incx 0) + (setf info 10)) + ((= incy 0) + (setf info 13))) + (cond + ((/= info 0) + (xerbla "ZGBMV " info) + (go end_label))) + (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one))) + (go end_label)) + (setf noconj (lsame trans "T")) + (cond + ((lsame trans "N") + (setf lenx n) + (setf leny m)) + (t + (setf lenx m) + (setf leny n))) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub lenx 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub leny 1) + incy))))) + (cond + ((/= beta one) + (cond + ((= incy 1) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + zero)))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%)))))))) + (t + (setf iy ky) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + zero) + (setf iy (f2cl-lib:int-add iy incy))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%))) + (setf iy (f2cl-lib:int-add iy incy)))))))))) + (if (= alpha zero) (go end_label)) + (setf kup1 (f2cl-lib:int-add ku 1)) + (cond + ((lsame trans "N") + (setf jx kx) + (cond + ((= incy 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf k (f2cl-lib:int-sub kup1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + ku)))) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum m) + (the fixnum + (f2cl-lib:int-add j kl)))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add k i) j) + ((1 lda) (1 *)) + a-%offset%)))))))) + (setf jx (f2cl-lib:int-add jx incx))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf iy ky) + (setf k (f2cl-lib:int-sub kup1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + ku)))) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum m) + (the fixnum + (f2cl-lib:int-add j kl)))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add k i) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf iy (f2cl-lib:int-add iy incy)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (if (> j ku) (setf ky (f2cl-lib:int-add ky incy)))))))) + (t + (setf jy ky) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp zero) + (setf k (f2cl-lib:int-sub kup1 j)) + (cond + (noconj + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + ku)))) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum m) + (the fixnum + (f2cl-lib:int-add j kl)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add k i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%))))))) + (t + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + ku)))) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum m) + (the fixnum + (f2cl-lib:int-add j kl)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add k i) j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp))) + (setf jy (f2cl-lib:int-add jy incy))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp zero) + (setf ix kx) + (setf k (f2cl-lib:int-sub kup1 j)) + (cond + (noconj + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + ku)))) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum m) + (the fixnum + (f2cl-lib:int-add j kl)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add k i) j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx))))) + (t + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + ku)))) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum m) + (the fixnum + (f2cl-lib:int-add j kl)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add k i) j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp))) + (setf jy (f2cl-lib:int-add jy incy)) + (if (> j ku) (setf kx (f2cl-lib:int-add kx incx))))))))) + end_label + (return + (values nil nil nil nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zgbmv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum fixnum +; fixnum fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil +; nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zgemv BLAS} +%\pagehead{zgemv}{zgemv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zgemv (trans m n alpha a lda x incx beta y incy) + (declare (type (array (complex double-float) (*)) y x a) + (type (complex double-float) beta alpha) + (type fixnum incy incx lda n m) + (type (simple-array character (*)) trans)) + (f2cl-lib:with-multi-array-data + ((trans character trans-%data% trans-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (x (complex double-float) x-%data% x-%offset%) + (y (complex double-float) y-%data% y-%offset%)) + (prog ((noconj nil) (i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) + (kx 0) (ky 0) (lenx 0) (leny 0) (temp #C(0.0 0.0))) + (declare (type (member t nil) noconj) + (type fixnum i info ix iy j jx jy kx ky lenx + leny) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 1)) + ((< m 0) + (setf info 2)) + ((< n 0) + (setf info 3)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info 6)) + ((= incx 0) + (setf info 8)) + ((= incy 0) + (setf info 11))) + (cond + ((/= info 0) + (xerbla "ZGEMV " info) + (go end_label))) + (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one))) + (go end_label)) + (setf noconj (lsame trans "T")) + (cond + ((lsame trans "N") + (setf lenx n) + (setf leny m)) + (t + (setf lenx m) + (setf leny n))) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub lenx 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub leny 1) + incy))))) + (cond + ((/= beta one) + (cond + ((= incy 1) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + zero)))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%)))))))) + (t + (setf iy ky) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + zero) + (setf iy (f2cl-lib:int-add iy incy))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i leny) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%))) + (setf iy (f2cl-lib:int-add iy incy)))))))))) + (if (= alpha zero) (go end_label)) + (cond + ((lsame trans "N") + (setf jx kx) + (cond + ((= incy 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))))) + (setf jx (f2cl-lib:int-add jx incx))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + (setf iy ky) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf iy (f2cl-lib:int-add iy incy)))))) + (setf jx (f2cl-lib:int-add jx incx))))))) + (t + (setf jy ky) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp zero) + (cond + (noconj + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%))))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp))) + (setf jy (f2cl-lib:int-add jy incy))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp zero) + (setf ix kx) + (cond + (noconj + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp))) + (setf jy (f2cl-lib:int-add jy incy)))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zgemv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zgerc BLAS} +%\pagehead{zgerc}{zgerc} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun zgerc (m n alpha x incx y incy a lda) + (declare (type (array (complex double-float) (*)) a y x) + (type (complex double-float) alpha) + (type fixnum lda incy incx n m)) + (f2cl-lib:with-multi-array-data + ((x (complex double-float) x-%data% x-%offset%) + (y (complex double-float) y-%data% y-%offset%) + (a (complex double-float) a-%data% a-%offset%)) + (prog ((i 0) (info 0) (ix 0) (j 0) (jy 0) (kx 0) (temp #C(0.0 0.0))) + (declare (type fixnum i info ix j jy kx) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((< m 0) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 5)) + ((= incy 0) + (setf info 7)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "ZGERC " info) + (go end_label))) + (if (or (= m 0) (= n 0) (= alpha zero)) (go end_label)) + (cond + ((> incy 0) + (setf jy 1)) + (t + (setf jy + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incy))))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref y (jy) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%)))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%) + temp))))))) + (setf jy (f2cl-lib:int-add jy incy))))) + (t + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub m 1) + incx))))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref y (jy) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%)))) + (setf ix kx) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp))) + (setf ix (f2cl-lib:int-add ix incx)))))) + (setf jy (f2cl-lib:int-add jy incy)))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zgerc fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla)))); + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zgeru BLAS} +%\pagehead{zgeru}{zgeru} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun zgeru (m n alpha x incx y incy a lda) + (declare (type (array (complex double-float) (*)) a y x) + (type (complex double-float) alpha) + (type fixnum lda incy incx n m)) + (f2cl-lib:with-multi-array-data + ((x (complex double-float) x-%data% x-%offset%) + (y (complex double-float) y-%data% y-%offset%) + (a (complex double-float) a-%data% a-%offset%)) + (prog ((i 0) (info 0) (ix 0) (j 0) (jy 0) (kx 0) (temp #C(0.0 0.0))) + (declare (type fixnum i info ix j jy kx) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((< m 0) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 5)) + ((= incy 0) + (setf info 7)) + ((< lda (max (the fixnum 1) (the fixnum m))) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "ZGERU " info) + (go end_label))) + (if (or (= m 0) (= n 0) (= alpha zero)) (go end_label)) + (cond + ((> incy 0) + (setf jy 1)) + (t + (setf jy + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incy))))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref y (jy) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%) + temp))))))) + (setf jy (f2cl-lib:int-add jy incy))))) + (t + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub m 1) + incx))))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref y (jy) ((1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%))) + (setf ix kx) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp))) + (setf ix (f2cl-lib:int-add ix incx)))))) + (setf jy (f2cl-lib:int-add jy incy)))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zgeru fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla)))); + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zhbmv BLAS} +%\pagehead{zhbmv}{zhbmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zhbmv (uplo n k alpha a lda x incx beta y incy) + (declare (type (array (complex double-float) (*)) y x a) + (type (complex double-float) beta alpha) + (type fixnum incy incx lda k n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (x (complex double-float) x-%data% x-%offset%) + (y (complex double-float) y-%data% y-%offset%)) + (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (kplus1 0) (kx 0) + (ky 0) (l 0) (temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0))) + (declare (type fixnum i info ix iy j jx jy kplus1 kx ky l) + (type (complex double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((< k 0) + (setf info 3)) + ((< lda (f2cl-lib:int-add k 1)) + (setf info 6)) + ((= incx 0) + (setf info 8)) + ((= incy 0) + (setf info 11))) + (cond + ((/= info 0) + (xerbla "ZHBMV " info) + (go end_label))) + (if (or (= n 0) (and (= alpha zero) (= beta one))) (go end_label)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incy))))) + (cond + ((/= beta one) + (cond + ((= incy 1) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + zero)))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%)))))))) + (t + (setf iy ky) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + zero) + (setf iy (f2cl-lib:int-add iy incy))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%))) + (setf iy (f2cl-lib:int-add iy incy)))))))))) + (if (= alpha zero) (go end_label)) + (cond + ((lsame uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)) + (* alpha temp2)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf ix kx) + (setf iy ky) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (cond + ((> j k) + (setf kx (f2cl-lib:int-add kx incx)) + (setf ky (f2cl-lib:int-add ky incy))))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)))) + (setf l (f2cl-lib:int-sub 1 j)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* alpha temp2)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)))) + (setf l (f2cl-lib:int-sub 1 j)) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)) + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zhbmv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zhemv BLAS} +%\pagehead{zhemv}{zhemv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zhemv (uplo n alpha a lda x incx beta y incy) + (declare (type (array (complex double-float) (*)) y x a) + (type (complex double-float) beta alpha) + (type fixnum incy incx lda n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (x (complex double-float) x-%data% x-%offset%) + (y (complex double-float) y-%data% y-%offset%)) + (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (kx 0) (ky 0) + (temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0))) + (declare (type fixnum i info ix iy j jx jy kx ky) + (type (complex double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info 5)) + ((= incx 0) + (setf info 7)) + ((= incy 0) + (setf info 10))) + (cond + ((/= info 0) + (xerbla "ZHEMV " info) + (go end_label))) + (if (or (= n 0) (and (= alpha zero) (= beta one))) (go end_label)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incy))))) + (cond + ((/= beta one) + (cond + ((= incy 1) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + zero)))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%)))))))) + (t + (setf iy ky) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + zero) + (setf iy (f2cl-lib:int-add iy incy))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%))) + (setf iy (f2cl-lib:int-add iy incy)))))))))) + (if (= alpha zero) (go end_label)) + (cond + ((lsame uplo "U") + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)) + (* alpha temp2)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf ix kx) + (setf iy ky) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* alpha temp2)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)))) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)) + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zhemv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame))));;; + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zher2 BLAS} +%\pagehead{zher2}{zher2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun zher2 (uplo n alpha x incx y incy a lda) + (declare (type (array (complex double-float) (*)) a y x) + (type (complex double-float) alpha) + (type fixnum lda incy incx n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (x (complex double-float) x-%data% x-%offset%) + (y (complex double-float) y-%data% y-%offset%) + (a (complex double-float) a-%data% a-%offset%)) + (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (kx 0) (ky 0) + (temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0))) + (declare (type fixnum i info ix iy j jx jy kx ky) + (type (complex double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 5)) + ((= incy 0) + (setf info 7)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "ZHER2 " info) + (go end_label))) + (if (or (= n 0) (= alpha zero)) (go end_label)) + (cond + ((or (/= incx 1) (/= incy 1)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incy))))) + (setf jx kx) + (setf jy ky))) + (cond + ((lsame uplo "U") + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) + (/= (f2cl-lib:fref y (j) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + temp2))))) + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%) + temp2))) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + '(complex double-float)))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf ix kx) + (setf iy ky) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + temp2))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%) + temp2))) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + '(complex double-float))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) + (/= (f2cl-lib:fref y (j) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%) + temp2))) 'double-float)) + '(complex double-float))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + temp2)))))) + (t + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + '(complex double-float)))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%) + temp2))) 'double-float)) + '(complex double-float))) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)) + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + temp2)))))) + (t + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + '(complex double-float))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zher2 fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zher BLAS} +%\pagehead{zher}{zher} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun zher (uplo n alpha x incx a lda) + (declare (type (array (complex double-float) (*)) a x) + (type (double-float) alpha) + (type fixnum lda incx n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (x (complex double-float) x-%data% x-%offset%) + (a (complex double-float) a-%data% a-%offset%)) + (prog ((i 0) (info 0) (ix 0) (j 0) (jx 0) (kx 0) (temp #C(0.0 0.0))) + (declare (type fixnum i info ix j jx kx) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 5)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info 7))) + (cond + ((/= info 0) + (xerbla "ZHER " info) + (go end_label))) + (if (or (= n 0) (= alpha (coerce (realpart zero) 'double-float))) + (go end_label)) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp))))) + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + (coerce (realpart + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + temp)) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + '(complex double-float)))))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf ix kx) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp))) + (setf ix (f2cl-lib:int-add ix incx)))) + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + (coerce (realpart + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + temp)) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + '(complex double-float))))) + (setf jx (f2cl-lib:int-add jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + (coerce (realpart + (* temp + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) 'double-float)) + '(complex double-float))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp)))))) + (t + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + '(complex double-float)))))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + (coerce (realpart + (* temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) 'double-float)) + '(complex double-float))) + (setf ix jx) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (+ + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp)))))) + (t + (setf (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float) + '(complex double-float))))) + (setf jx (f2cl-lib:int-add jx incx)))))))) + end_label + (return (values nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zher fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum (double-float) +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zhpmv BLAS} +%\pagehead{zhpmv}{zhpmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zhpmv (uplo n alpha ap x incx beta y incy) + (declare (type (array (complex double-float) (*)) y x ap) + (type (complex double-float) beta alpha) + (type fixnum incy incx n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (ap (complex double-float) ap-%data% ap-%offset%) + (x (complex double-float) x-%data% x-%offset%) + (y (complex double-float) y-%data% y-%offset%)) + (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (k 0) (kk 0) + (kx 0) (ky 0) (temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0))) + (declare (type fixnum i info ix iy j jx jy k kk kx ky) + (type (complex double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 6)) + ((= incy 0) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "ZHPMV " info) + (go end_label))) + (if (or (= n 0) (and (= alpha zero) (= beta one))) (go end_label)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incy))))) + (cond + ((/= beta one) + (cond + ((= incy 1) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + zero)))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%)))))))) + (t + (setf iy ky) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + zero) + (setf iy (f2cl-lib:int-add iy incy))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* beta + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%))) + (setf iy (f2cl-lib:int-add iy incy)))))))))) + (if (= alpha zero) (go end_label)) + (setf kk 1) + (cond + ((lsame uplo "U") + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf k kk) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float)) + (* alpha temp2))) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf ix kx) + (setf iy ky) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub 2))) + nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float)) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float)))) + (setf k (f2cl-lib:int-add kk 1)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) + (* alpha temp2))) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf jx kx) + (setf jy ky) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) + (setf temp2 zero) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* temp1 + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float)))) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) + (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub j))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)) + (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (+ + (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) + (* temp1 + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))) + (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) + (* alpha temp2))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zhpmv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; (array (complex double-float) (*)) +; fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zhpr2 BLAS} +%\pagehead{zhpr2}{zhpr2} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun zhpr2 (uplo n alpha x incx y incy ap) + (declare (type (array (complex double-float) (*)) ap y x) + (type (complex double-float) alpha) + (type fixnum incy incx n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (x (complex double-float) x-%data% x-%offset%) + (y (complex double-float) y-%data% y-%offset%) + (ap (complex double-float) ap-%data% ap-%offset%)) + (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (k 0) (kk 0) + (kx 0) (ky 0) (temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0))) + (declare (type fixnum i info ix iy j jx jy k kk kx ky) + (type (complex double-float) temp1 temp2)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 5)) + ((= incy 0) + (setf info 7))) + (cond + ((/= info 0) + (xerbla "ZHPR2 " info) + (go end_label))) + (if (or (= n 0) (= alpha zero)) (go end_label)) + (cond + ((or (/= incx 1) (/= incy 1)) + (cond + ((> incx 0) + (setf kx 1)) + (t + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))))) + (cond + ((> incy 0) + (setf ky 1)) + (t + (setf ky + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incy))))) + (setf jx kx) + (setf jy ky))) + (setf kk 1) + (cond + ((lsame uplo "U") + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) + (/= (f2cl-lib:fref y (j) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf k kk) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + temp2))) + (setf k (f2cl-lib:int-add k 1)))) + (setf (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%) + temp2))) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float) + '(complex double-float))))) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf ix kx) + (setf iy ky) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub 2))) + nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + temp2))) + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)))) + (setf (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%) + temp2))) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float) + '(complex double-float))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (cond + ((and (= incx 1) (= incy 1)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) + (/= (f2cl-lib:fref y (j) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (j) + ((1 *)) + y-%offset%) + temp2))) 'double-float)) + '(complex double-float))) + (setf k (f2cl-lib:int-add kk 1)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (i) + ((1 *)) + y-%offset%) + temp2))) + (setf k (f2cl-lib:int-add k 1))))) + (t + (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float) + '(complex double-float))))) + (setf kk + (f2cl-lib:int-add + (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) + 1))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (jy) + ((1 *)) + y-%offset%) + temp2))) 'double-float)) + '(complex double-float))) + (setf ix jx) + (setf iy jy) + (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) + (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub j))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf iy (f2cl-lib:int-add iy incy)) + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp1) + (* + (f2cl-lib:fref y-%data% + (iy) + ((1 *)) + y-%offset%) + temp2)))))) + (t + (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float) + '(complex double-float))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf jy (f2cl-lib:int-add jy incy)) + (setf kk + (f2cl-lib:int-add + (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) + 1)))))))) + end_label + (return (values nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zhpr2 fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*))) +; :return-values '(nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))); + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zhpr BLAS} +%\pagehead{zhpr}{zhpr} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun zhpr (uplo n alpha x incx ap) + (declare (type (array (complex double-float) (*)) ap x) + (type (double-float) alpha) + (type fixnum incx n) + (type (simple-array character (*)) uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (x (complex double-float) x-%data% x-%offset%) + (ap (complex double-float) ap-%data% ap-%offset%)) + (prog ((i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0) (kk 0) (kx 0) + (temp #C(0.0 0.0))) + (declare (type fixnum i info ix j jx k kk kx) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((< n 0) + (setf info 2)) + ((= incx 0) + (setf info 5))) + (cond + ((/= info 0) + (xerbla "ZHPR " info) + (go end_label))) + (if (or (= n 0) (= alpha (coerce (realpart zero) 'double-float))) + (go end_label)) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (setf kk 1) + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf k kk) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp))) + (setf k (f2cl-lib:int-add k 1)))) + (setf (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float) + (coerce (realpart + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + temp)) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float) + '(complex double-float))))) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf ix kx) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub 2))) + nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp))) + (setf ix (f2cl-lib:int-add ix incx)))) + (setf (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float) + (coerce (realpart + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + temp)) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)) 'double-float) + '(complex double-float))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float) + (coerce (realpart + (* temp + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%))) 'double-float)) + '(complex double-float))) + (setf k (f2cl-lib:int-add kk 1)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + temp))) + (setf k (f2cl-lib:int-add k 1))))) + (t + (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float) + '(complex double-float))))) + (setf kk + (f2cl-lib:int-add + (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) + 1))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) + '(complex double-float))) + (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float) + (coerce (realpart + (* temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%))) 'double-float)) + '(complex double-float))) + (setf ix jx) + (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) + (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub j))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (+ + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (* + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + temp)))))) + (t + (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)) 'double-float) + '(complex double-float))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk + (f2cl-lib:int-add + (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) + 1)))))))) + end_label + (return (values nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zhpr fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum (double-float) +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*))) +; :return-values '(nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ztbmv BLAS} +%\pagehead{ztbmv}{ztbmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun ztbmv (uplo trans diag n k a lda x incx) + (declare (type (array (complex double-float) (*)) x a) + (type fixnum incx lda k n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (x (complex double-float) x-%data% x-%offset%)) + (prog ((noconj nil) (nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) + (kplus1 0) (kx 0) (l 0) (temp #C(0.0 0.0))) + (declare (type (member t nil) noconj nounit) + (type fixnum i info ix j jx kplus1 kx l) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< k 0) + (setf info 5)) + ((< lda (f2cl-lib:int-add k 1)) + (setf info 7)) + ((= incx 0) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "ZTBMV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf noconj (lsame trans "T")) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%))))))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (setf l (f2cl-lib:int-sub kplus1 j)) + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (if (> j k) (setf kx (f2cl-lib:int-add kx incx)))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub 1 j)) + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%))))))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (setf l (f2cl-lib:int-sub 1 j)) + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf jx (f2cl-lib:int-sub jx incx)) + (if (>= (f2cl-lib:int-sub n j) k) + (setf kx (f2cl-lib:int-sub kx incx)))))))))) + (t + (cond + ((lsame uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub kplus1 j)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf kx (f2cl-lib:int-sub kx incx)) + (setf ix kx) + (setf l (f2cl-lib:int-sub kplus1 j)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub 1 j)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf kx (f2cl-lib:int-add kx incx)) + (setf ix kx) + (setf l (f2cl-lib:int-sub 1 j)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::ztbmv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))); + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ztbsv BLAS} +%\pagehead{ztbsv}{ztbsv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun ztbsv (uplo trans diag n k a lda x incx) + (declare (type (array (complex double-float) (*)) x a) + (type fixnum incx lda k n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (x (complex double-float) x-%data% x-%offset%)) + (prog ((noconj nil) (nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) + (kplus1 0) (kx 0) (l 0) (temp #C(0.0 0.0))) + (declare (type (member t nil) noconj nounit) + (type fixnum i info ix j jx kplus1 kx l) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< k 0) + (setf info 5)) + ((< lda (f2cl-lib:int-add k 1)) + (setf info 7)) + ((= incx 0) + (setf info 9))) + (cond + ((/= info 0) + (xerbla "ZTBSV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf noconj (lsame trans "T")) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf l (f2cl-lib:int-sub kplus1 j)) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%))))))))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf kx (f2cl-lib:int-sub kx incx)) + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf ix kx) + (setf l (f2cl-lib:int-sub kplus1 j)) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k))))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))))) + (setf jx (f2cl-lib:int-sub jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf l (f2cl-lib:int-sub 1 j)) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%))))))))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf kx (f2cl-lib:int-add kx incx)) + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf ix kx) + (setf l (f2cl-lib:int-sub 1 j)) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k)))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))))) + (setf jx (f2cl-lib:int-add jx incx))))))))) + (t + (cond + ((lsame uplo "U") + (setf kplus1 (f2cl-lib:int-add k 1)) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub kplus1 j)) + (cond + (noconj + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (setf l (f2cl-lib:int-sub kplus1 j)) + (cond + (noconj + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (i + (max (the fixnum 1) + (the fixnum + (f2cl-lib:int-add j + (f2cl-lib:int-sub + k)))) + (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (kplus1 j) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)) + (if (> j k) (setf kx (f2cl-lib:int-add kx incx)))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf l (f2cl-lib:int-sub 1 j)) + (cond + (noconj + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (setf l (f2cl-lib:int-sub 1 j)) + (cond + (noconj + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (i + (min (the fixnum n) + (the fixnum + (f2cl-lib:int-add j k))) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + ((f2cl-lib:int-add l i) + j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (1 j) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx)) + (if (>= (f2cl-lib:int-sub n j) k) + (setf kx (f2cl-lib:int-sub kx incx))))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::ztbsv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))); + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ztpmv BLAS} +%\pagehead{ztpmv}{ztpmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun ztpmv (uplo trans diag n ap x incx) + (declare (type (array (complex double-float) (*)) x ap) + (type fixnum incx n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (ap (complex double-float) ap-%data% ap-%offset%) + (x (complex double-float) x-%data% x-%offset%)) + (prog ((noconj nil) (nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0) + (kk 0) (kx 0) (temp #C(0.0 0.0))) + (declare (type (member t nil) noconj nounit) + (type fixnum i info ix j jx k kk kx) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((= incx 0) + (setf info 7))) + (cond + ((/= info 0) + (xerbla "ZTPMV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf noconj (lsame trans "T")) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (setf kk 1) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k kk) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)))))) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub + 2))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%)))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k kk) + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-sub k 1)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk n) + j)) + ((1 *)) + ap-%offset%)))))) + (setf kk + (f2cl-lib:int-sub kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (k kk + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub + (f2cl-lib:int-add + n + (f2cl-lib:int-sub + (f2cl-lib:int-add + j + 1)))))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk n) + j)) + ((1 *)) + ap-%offset%)))))) + (setf jx (f2cl-lib:int-sub jx incx)) + (setf kk + (f2cl-lib:int-sub kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))))))) + (t + (cond + ((lsame uplo "U") + (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k (f2cl-lib:int-sub kk 1)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-sub k 1))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%))))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-sub k 1)))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp) + (setf kk (f2cl-lib:int-sub kk j))))) + (t + (setf jx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix jx) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (f2cl-lib:fdo (k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub + j) + 1)) + nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%))))) + (f2cl-lib:fdo (k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub + j) + 1)) + nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx)) + (setf kk (f2cl-lib:int-sub kk j))))))) + (t + (setf kk 1) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k (f2cl-lib:int-add kk 1)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%))))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix jx) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) + (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub + j))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%))))) + (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) + (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub + j))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1))))))))))) + end_label + (return (values nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::ztpmv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum +; (array (complex double-float) (*)) +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame))));; + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ztpsv BLAS} +%\pagehead{ztpsv}{ztpsv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun ztpsv (uplo trans diag n ap x incx) + (declare (type (array (complex double-float) (*)) x ap) + (type fixnum incx n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (ap (complex double-float) ap-%data% ap-%offset%) + (x (complex double-float) x-%data% x-%offset%)) + (prog ((noconj nil) (nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0) + (kk 0) (kx 0) (temp #C(0.0 0.0))) + (declare (type (member t nil) noconj nounit) + (type fixnum i info ix j jx k kk kx) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((= incx 0) + (setf info 7))) + (cond + ((/= info 0) + (xerbla "ZTPSV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf noconj (lsame trans "T")) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k (f2cl-lib:int-sub kk 1)) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-sub k 1)))))) + (setf kk (f2cl-lib:int-sub kk j))))) + (t + (setf jx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix jx) + (f2cl-lib:fdo (k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub + j) + 1)) + nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))))))) + (setf jx (f2cl-lib:int-sub jx incx)) + (setf kk (f2cl-lib:int-sub kk j))))))) + (t + (setf kk 1) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k (f2cl-lib:int-add kk 1)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))))) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref ap-%data% + (kk) + ((1 *)) + ap-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix jx) + (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) + (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + n + (f2cl-lib:int-sub + j))) + nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)))))))) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk + (f2cl-lib:int-add kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))))))) + (t + (cond + ((lsame uplo "U") + (setf kk 1) + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k kk) + (cond + (noconj + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-add k 1)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk + j) + 1)) + ((1 *)) + ap-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp) + (setf kk (f2cl-lib:int-add kk j))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (cond + (noconj + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub + 2))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk j) + 1)) + ((1 *)) + ap-%offset%))))) + (t + (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add kk + j + (f2cl-lib:int-sub + 2))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-sub + (f2cl-lib:int-add kk + j) + 1)) + ((1 *)) + ap-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)) + (setf kk (f2cl-lib:int-add kk j))))))) + (t + (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (setf k kk) + (cond + (noconj + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-sub k 1)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk n) + j)) + ((1 *)) + ap-%offset%))))) + (t + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))) + (setf k (f2cl-lib:int-sub k 1)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk + n) + j)) + ((1 *)) + ap-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp) + (setf kk + (f2cl-lib:int-sub kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1)))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix kx) + (cond + (noconj + (f2cl-lib:fdo (k kk + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub + (f2cl-lib:int-add + n + (f2cl-lib:int-sub + (f2cl-lib:int-add + j + 1)))))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk n) + j)) + ((1 *)) + ap-%offset%))))) + (t + (f2cl-lib:fdo (k kk + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + ((> k + (f2cl-lib:int-add kk + (f2cl-lib:int-sub + (f2cl-lib:int-add + n + (f2cl-lib:int-sub + (f2cl-lib:int-add + j + 1)))))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + (k) + ((1 *)) + ap-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref ap-%data% + ((f2cl-lib:int-add + (f2cl-lib:int-sub kk + n) + j)) + ((1 *)) + ap-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx)) + (setf kk + (f2cl-lib:int-sub kk + (f2cl-lib:int-add + (f2cl-lib:int-sub n j) + 1))))))))))) + end_label + (return (values nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::ztpsv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum +; (array (complex double-float) (*)) +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame))));; + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ztrmv BLAS} +%\pagehead{ztrmv}{ztrmv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun ztrmv (uplo trans diag n a lda x incx) + (declare (type (array (complex double-float) (*)) x a) + (type fixnum incx lda n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (x (complex double-float) x-%data% x-%offset%)) + (prog ((noconj nil) (nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) + (kx 0) (temp #C(0.0 0.0))) + (declare (type (member t nil) noconj nounit) + (type fixnum i info ix j jx kx) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info 6)) + ((= incx 0) + (setf info 8))) + (cond + ((/= info 0) + (xerbla "ZTRMV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf noconj (lsame trans "T")) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf jx (f2cl-lib:int-add jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))))))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix kx) + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (+ + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (* + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf jx (f2cl-lib:int-sub jx incx))))))))) + (t + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix jx) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (setf ix jx) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx)))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::ztrmv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))); + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ztrsv BLAS} +%\pagehead{ztrsv}{ztrsv} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((zero (complex 0.0 0.0))) + (declare (type (complex double-float) zero)) + (defun ztrsv (uplo trans diag n a lda x incx) + (declare (type (array (complex double-float) (*)) x a) + (type fixnum incx lda n) + (type (simple-array character (*)) diag trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (diag character diag-%data% diag-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (x (complex double-float) x-%data% x-%offset%)) + (prog ((noconj nil) (nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) + (kx 0) (temp #C(0.0 0.0))) + (declare (type (member t nil) noconj nounit) + (type fixnum i info ix j jx kx) + (type (complex double-float) temp)) + (setf info 0) + (cond + ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum n))) + (setf info 6)) + ((= incx 0) + (setf info 8))) + (cond + ((/= info 0) + (xerbla "ZTRSV " info) + (go end_label))) + (if (= n 0) (go end_label)) + (setf noconj (lsame trans "T")) + (setf nounit (lsame diag "N")) + (cond + ((<= incx 0) + (setf kx + (f2cl-lib:int-sub 1 + (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) + incx)))) + ((/= incx 1) + (setf kx 1))) + (cond + ((lsame trans "N") + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%))))))))))) + (t + (setf jx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix jx) + (f2cl-lib:fdo (i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1)) + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf ix (f2cl-lib:int-sub ix incx)) + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))))) + (setf jx (f2cl-lib:int-sub jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (j) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (j) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%))))))))))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) + (if nounit + (setf (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (/ + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%) + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp + (f2cl-lib:fref x-%data% + (jx) + ((1 *)) + x-%offset%)) + (setf ix jx) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf ix (f2cl-lib:int-add ix incx)) + (setf (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (- + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)))))))) + (setf jx (f2cl-lib:int-add jx incx))))))))) + (t + (cond + ((lsame uplo "U") + (cond + ((= incx 1) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (cond + (noconj + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf jx kx) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf ix kx) + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (cond + (noconj + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-add ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-add jx incx))))))) + (t + (cond + ((= incx 1) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) + (cond + (noconj + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (i) + ((1 *)) + x-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) + temp)))) + (t + (setf kx + (f2cl-lib:int-add kx + (f2cl-lib:int-mul + (f2cl-lib:int-sub n 1) + incx))) + (setf jx kx) + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf ix kx) + (setf temp + (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) + (cond + (noconj + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (i n + (f2cl-lib:int-add i + (f2cl-lib:int-sub 1))) + ((> i (f2cl-lib:int-add j 1)) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref x-%data% + (ix) + ((1 *)) + x-%offset%)))) + (setf ix (f2cl-lib:int-sub ix incx)))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) + temp) + (setf jx (f2cl-lib:int-sub jx incx)))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::ztrsv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))); + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{BLAS Level 3} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dgemm BLAS} +%\pagehead{dgemm}{dgemm} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0) (zero 0.0)) + (declare (type (double-float 1.0 1.0) one) + (type (double-float 0.0 0.0) zero)) + (defun dgemm (transa transb m n k alpha a lda b ldb$ beta c ldc) + (declare (type (array double-float (*)) c b a) + (type (double-float) beta alpha) + (type fixnum ldc ldb$ lda k n m) + (type (simple-array character (*)) transb transa)) + (f2cl-lib:with-multi-array-data + ((transa character transa-%data% transa-%offset%) + (transb character transb-%data% transb-%offset%) + (a double-float a-%data% a-%offset%) + (b double-float b-%data% b-%offset%) + (c double-float c-%data% c-%offset%)) + (prog ((temp 0.0) (i 0) (info 0) (j 0) (l 0) (ncola 0) (nrowa 0) + (nrowb 0) (nota nil) (notb nil)) + (declare (type (double-float) temp) + (type fixnum i info j l ncola nrowa nrowb) + (type (member t nil) nota notb)) + (setf nota (lsame transa "N")) + (setf notb (lsame transb "N")) + (cond + (nota + (setf nrowa m) + (setf ncola k)) + (t + (setf nrowa k) + (setf ncola m))) + (cond + (notb + (setf nrowb k)) + (t + (setf nrowb n))) + (setf info 0) + (cond + ((and (not nota) (not (lsame transa "C")) (not (lsame transa "T"))) + (setf info 1)) + ((and (not notb) (not (lsame transb "C")) (not (lsame transb "T"))) + (setf info 2)) + ((< m 0) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< k 0) + (setf info 5)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 8)) + ((< ldb$ + (max (the fixnum 1) (the fixnum nrowb))) + (setf info 10)) + ((< ldc (max (the fixnum 1) (the fixnum m))) + (setf info 13))) + (cond + ((/= info 0) + (xerbla "DGEMM " info) + (go end_label))) + (if (or (= m 0) (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) + (go end_label)) + (cond + ((= alpha zero) + (cond + ((= beta zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))) + (go end_label))) + (cond + (notb + (cond + (nota + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (l j) ((1 ldb$) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (l j) + ((1 ldb$) (1 *)) + b-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%))))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (l j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* alpha temp))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))))))) + (t + (cond + (nota + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%))))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* alpha temp))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)))))))))))))) + end_label + (return + (values nil nil nil nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgemm fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; fixnum (double-float) +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum +; (double-float) (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil +; nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dsymm BLAS} +%\pagehead{dsymm}{dsymm} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0) (zero 0.0)) + (declare (type (double-float 1.0 1.0) one) + (type (double-float 0.0 0.0) zero)) + (defun dsymm (side uplo m n alpha a lda b ldb$ beta c ldc) + (declare (type (array double-float (*)) c b a) + (type (double-float) beta alpha) + (type fixnum ldc ldb$ lda n m) + (type (simple-array character (*)) uplo side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (uplo character uplo-%data% uplo-%offset%) + (a double-float a-%data% a-%offset%) + (b double-float b-%data% b-%offset%) + (c double-float c-%data% c-%offset%)) + (prog ((temp1 0.0) (temp2 0.0) (i 0) (info 0) (j 0) (k 0) (nrowa 0) + (upper nil)) + (declare (type (double-float) temp1 temp2) + (type fixnum i info j k nrowa) + (type (member t nil) upper)) + (cond + ((lsame side "L") + (setf nrowa m)) + (t + (setf nrowa n))) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not (lsame side "L")) (not (lsame side "R"))) + (setf info 1)) + ((and (not upper) (not (lsame uplo "L"))) + (setf info 2)) + ((< m 0) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 7)) + ((< ldb$ (max (the fixnum 1) (the fixnum m))) + (setf info 9)) + ((< ldc (max (the fixnum 1) (the fixnum m))) + (setf info 12))) + (cond + ((/= info 0) + (xerbla "DSYMM " info) + (go end_label))) + (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one))) + (go end_label)) + (cond + ((= alpha zero) + (cond + ((= beta zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))) + (go end_label))) + (cond + ((lsame side "L") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 zero) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add i + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* temp1 + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)) + (* temp1 + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i m (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 zero) + (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) + (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* temp1 + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)) + (* temp1 + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)) + (* temp1 + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + (upper + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))) + (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + (upper + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dsymm fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; (double-float) (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (double-float) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame))));; + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dsyr2k BLAS} +%\pagehead{dsyr2k}{dsyr2k} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0) (zero 0.0)) + (declare (type (double-float 1.0 1.0) one) + (type (double-float 0.0 0.0) zero)) + (defun dsyr2k (uplo trans n k alpha a lda b ldb$ beta c ldc) + (declare (type (array double-float (*)) c b a) + (type (double-float) beta alpha) + (type fixnum ldc ldb$ lda k n) + (type (simple-array character (*)) trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (a double-float a-%data% a-%offset%) + (b double-float b-%data% b-%offset%) + (c double-float c-%data% c-%offset%)) + (prog ((temp1 0.0) (temp2 0.0) (i 0) (info 0) (j 0) (l 0) (nrowa 0) + (upper nil)) + (declare (type (double-float) temp1 temp2) + (type fixnum i info j l nrowa) + (type (member t nil) upper)) + (cond + ((lsame trans "N") + (setf nrowa n)) + (t + (setf nrowa k))) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not upper) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((< n 0) + (setf info 3)) + ((< k 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 7)) + ((< ldb$ + (max (the fixnum 1) (the fixnum nrowa))) + (setf info 9)) + ((< ldc (max (the fixnum 1) (the fixnum n))) + (setf info 12))) + (cond + ((/= info 0) + (xerbla "DSYR2K" info) + (go end_label))) + (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) + (go end_label)) + (cond + ((= alpha zero) + (cond + (upper + (cond + ((= beta zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)))))))))) + (t + (cond + ((= beta zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))))) + (go end_label))) + (cond + ((lsame trans "N") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) + (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%) + temp1) + (* + (f2cl-lib:fref b-%data% + (i l) + ((1 ldb$) (1 *)) + b-%offset%) + temp2)))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) + (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%) + temp1) + (* + (f2cl-lib:fref b-%data% + (i l) + ((1 ldb$) (1 *)) + b-%offset%) + temp2)))))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf temp1 zero) + (setf temp2 zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp1 + (+ temp1 + (* + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (l j) + ((1 ldb$) (1 *)) + b-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (l i) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp1) (* alpha temp2)))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)) + (* alpha temp1) + (* alpha temp2)))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp1 zero) + (setf temp2 zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp1 + (+ temp1 + (* + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (l j) + ((1 ldb$) (1 *)) + b-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (l i) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp1) (* alpha temp2)))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)) + (* alpha temp1) + (* alpha temp2))))))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dsyr2k +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; (double-float) (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (double-float) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))); + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dsyrk BLAS} +%\pagehead{dsyrk}{dsyrk} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0) (zero 0.0)) + (declare (type (double-float 1.0 1.0) one) + (type (double-float 0.0 0.0) zero)) + (defun dsyrk (uplo trans n k alpha a lda beta c ldc) + (declare (type (array double-float (*)) c a) + (type (double-float) beta alpha) + (type fixnum ldc lda k n) + (type (simple-array character (*)) trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (a double-float a-%data% a-%offset%) + (c double-float c-%data% c-%offset%)) + (prog ((temp 0.0) (i 0) (info 0) (j 0) (l 0) (nrowa 0) (upper nil)) + (declare (type (double-float) temp) + (type fixnum i info j l nrowa) + (type (member t nil) upper)) + (cond + ((lsame trans "N") + (setf nrowa n)) + (t + (setf nrowa k))) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not upper) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) + (not (lsame trans "T")) + (not (lsame trans "C"))) + (setf info 2)) + ((< n 0) + (setf info 3)) + ((< k 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 7)) + ((< ldc (max (the fixnum 1) (the fixnum n))) + (setf info 10))) + (cond + ((/= info 0) + (xerbla "DSYRK " info) + (go end_label))) + (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) + (go end_label)) + (cond + ((= alpha zero) + (cond + (upper + (cond + ((= beta zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)))))))))) + (t + (cond + ((= beta zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))))) + (go end_label))) + (cond + ((lsame trans "N") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%))))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%))))))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf temp zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* alpha temp))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* alpha temp))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)))))))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dsyrk fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; (double-float) (array double-float (*)) +; fixnum (double-float) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dtrmm BLAS} +%\pagehead{dtrmm}{dtrmm} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0) (zero 0.0)) + (declare (type (double-float 1.0 1.0) one) + (type (double-float 0.0 0.0) zero)) + (defun dtrmm (side uplo transa diag m n alpha a lda b ldb$) + (declare (type (array double-float (*)) b a) + (type (double-float) alpha) + (type fixnum ldb$ lda n m) + (type (simple-array character (*)) diag transa uplo side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (uplo character uplo-%data% uplo-%offset%) + (transa character transa-%data% transa-%offset%) + (diag character diag-%data% diag-%offset%) + (a double-float a-%data% a-%offset%) + (b double-float b-%data% b-%offset%)) + (prog ((temp 0.0) (i 0) (info 0) (j 0) (k 0) (nrowa 0) (lside nil) + (nounit nil) (upper nil)) + (declare (type (double-float) temp) + (type fixnum i info j k nrowa) + (type (member t nil) lside nounit upper)) + (setf lside (lsame side "L")) + (cond + (lside + (setf nrowa m)) + (t + (setf nrowa n))) + (setf nounit (lsame diag "N")) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not lside) (not (lsame side "R"))) + (setf info 1)) + ((and (not upper) (not (lsame uplo "L"))) + (setf info 2)) + ((and (not (lsame transa "N")) + (not (lsame transa "T")) + (not (lsame transa "C"))) + (setf info 3)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 4)) + ((< m 0) + (setf info 5)) + ((< n 0) + (setf info 6)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 9)) + ((< ldb$ (max (the fixnum 1) (the fixnum m))) + (setf info 11))) + (cond + ((/= info 0) + (xerbla "DTRMM " info) + (go end_label))) + (if (= n 0) (go end_label)) + (cond + ((= alpha zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + zero))))) + (go end_label))) + (cond + (lside + (cond + ((lsame transa "N") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add k + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (+ + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + temp)))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (k m + (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + temp) + (if nounit + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add k 1) + (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (+ + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%))))))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i m + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add i + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha temp))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) + (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha temp))))))))))) + (t + (cond + ((lsame transa "N") + (cond + (upper + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp alpha) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (+ + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp alpha) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))) + (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) + (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (+ + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (+ + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (setf temp alpha) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (cond + ((/= temp one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (t + (f2cl-lib:fdo (k n (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k 1) nil) + (tagbody + (f2cl-lib:fdo (j (f2cl-lib:int-add k 1) + (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (+ + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (setf temp alpha) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (cond + ((/= temp one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dtrmm fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; (double-float) (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))); + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{dtrsm BLAS} +%\pagehead{dtrsm}{dtrsm} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0) (zero 0.0)) + (declare (type (double-float 1.0 1.0) one) + (type (double-float 0.0 0.0) zero)) + (defun dtrsm (side uplo transa diag m n alpha a lda b ldb$) + (declare (type (array double-float (*)) b a) + (type (double-float) alpha) + (type fixnum ldb$ lda n m) + (type (simple-array character (*)) diag transa uplo side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (uplo character uplo-%data% uplo-%offset%) + (transa character transa-%data% transa-%offset%) + (diag character diag-%data% diag-%offset%) + (a double-float a-%data% a-%offset%) + (b double-float b-%data% b-%offset%)) + (prog ((temp 0.0) (i 0) (info 0) (j 0) (k 0) (nrowa 0) (lside nil) + (nounit nil) (upper nil)) + (declare (type (double-float) temp) + (type fixnum i info j k nrowa) + (type (member t nil) lside nounit upper)) + (setf lside (lsame side "L")) + (cond + (lside + (setf nrowa m)) + (t + (setf nrowa n))) + (setf nounit (lsame diag "N")) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not lside) (not (lsame side "R"))) + (setf info 1)) + ((and (not upper) (not (lsame uplo "L"))) + (setf info 2)) + ((and (not (lsame transa "N")) + (not (lsame transa "T")) + (not (lsame transa "C"))) + (setf info 3)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 4)) + ((< m 0) + (setf info 5)) + ((< n 0) + (setf info 6)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 9)) + ((< ldb$ (max (the fixnum 1) (the fixnum m))) + (setf info 11))) + (cond + ((/= info 0) + (xerbla "DTRSM " info) + (go end_label))) + (if (= n 0) (go end_label)) + (cond + ((= alpha zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + zero))))) + (go end_label))) + (cond + (lside + (cond + ((lsame transa "N") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= alpha one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (k m + (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) + (if nounit + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (/ + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add k + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (- + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%))))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= alpha one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) + (if nounit + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (/ + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add k 1) + (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (- + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%))))))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add i + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + temp)))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i m + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) + (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + temp)))))))))) + (t + (cond + ((lsame transa "N") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= alpha one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (- + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (cond + (nounit + (setf temp + (/ one + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (t + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= alpha one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) + (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (- + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (cond + (nounit + (setf temp + (/ one + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (k n (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k 1) nil) + (tagbody + (cond + (nounit + (setf temp + (/ one + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) + (setf temp + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (- + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (cond + ((/= alpha one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (t + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + (nounit + (setf temp + (/ one + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (j (f2cl-lib:int-add k 1) + (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) + (setf temp + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (- + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (cond + ((/= alpha one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dtrsm fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; (double-float) (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))); + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zgemm BLAS} +%\pagehead{zgemm}{zgemm} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zgemm (transa transb m n k alpha a lda b ldb$ beta c ldc) + (declare (type (array (complex double-float) (*)) c b a) + (type (complex double-float) beta alpha) + (type fixnum ldc ldb$ lda k n m) + (type (simple-array character (*)) transb transa)) + (f2cl-lib:with-multi-array-data + ((transa character transa-%data% transa-%offset%) + (transb character transb-%data% transb-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (b (complex double-float) b-%data% b-%offset%) + (c (complex double-float) c-%data% c-%offset%)) + (prog ((temp #C(0.0 0.0)) (i 0) (info 0) (j 0) (l 0) (ncola 0) (nrowa 0) + (nrowb 0) (conja nil) (conjb nil) (nota nil) (notb nil)) + (declare (type (complex double-float) temp) + (type fixnum i info j l ncola nrowa nrowb) + (type (member t nil) conja conjb nota notb)) + (setf nota (lsame transa "N")) + (setf notb (lsame transb "N")) + (setf conja (lsame transa "C")) + (setf conjb (lsame transb "C")) + (cond + (nota + (setf nrowa m) + (setf ncola k)) + (t + (setf nrowa k) + (setf ncola m))) + (cond + (notb + (setf nrowb k)) + (t + (setf nrowb n))) + (setf info 0) + (cond + ((and (not nota) (not conja) (not (lsame transa "T"))) + (setf info 1)) + ((and (not notb) (not conjb) (not (lsame transb "T"))) + (setf info 2)) + ((< m 0) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< k 0) + (setf info 5)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 8)) + ((< ldb$ + (max (the fixnum 1) (the fixnum nrowb))) + (setf info 10)) + ((< ldc (max (the fixnum 1) (the fixnum m))) + (setf info 13))) + (cond + ((/= info 0) + (xerbla "ZGEMM " info) + (go end_label))) + (if (or (= m 0) (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) + (go end_label)) + (cond + ((= alpha zero) + (cond + ((= beta zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))) + (go end_label))) + (cond + (notb + (cond + (nota + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (l j) ((1 ldb$) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (l j) + ((1 ldb$) (1 *)) + b-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%))))))))))))) + (conja + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref b-%data% + (l j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* alpha temp))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (l j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* alpha temp))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))))))) + (nota + (cond + (conjb + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%)))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%))))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%))))))))))))))) + (conja + (cond + (conjb + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:dconjg + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* alpha temp))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* alpha temp))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))))))) + (t + (cond + (conjb + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:dconjg + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* alpha temp))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* alpha temp))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)))))))))))))) + end_label + (return + (values nil nil nil nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zgemm fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil +; nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zhemm BLAS} +%\pagehead{zhemm}{zhemm} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zhemm (side uplo m n alpha a lda b ldb$ beta c ldc) + (declare (type (array (complex double-float) (*)) c b a) + (type (complex double-float) beta alpha) + (type fixnum ldc ldb$ lda n m) + (type (simple-array character (*)) uplo side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (uplo character uplo-%data% uplo-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (b (complex double-float) b-%data% b-%offset%) + (c (complex double-float) c-%data% c-%offset%)) + (prog ((temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0)) (i 0) (info 0) (j 0) (k 0) + (nrowa 0) (upper nil)) + (declare (type (complex double-float) temp1 temp2) + (type fixnum i info j k nrowa) + (type (member t nil) upper)) + (cond + ((lsame side "L") + (setf nrowa m)) + (t + (setf nrowa n))) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not (lsame side "L")) (not (lsame side "R"))) + (setf info 1)) + ((and (not upper) (not (lsame uplo "L"))) + (setf info 2)) + ((< m 0) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 7)) + ((< ldb$ (max (the fixnum 1) (the fixnum m))) + (setf info 9)) + ((< ldc (max (the fixnum 1) (the fixnum m))) + (setf info 12))) + (cond + ((/= info 0) + (xerbla "ZHEMM " info) + (go end_label))) + (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one))) + (go end_label)) + (cond + ((= alpha zero) + (cond + ((= beta zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))) + (go end_label))) + (cond + ((lsame side "L") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 zero) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add i + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%))))))) + (cond + ((= beta zero) + (setf + (f2cl-lib:fref c-%data% (i j) ((1 ldc) (1 *)) + c-%offset%) + (+ + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) + a-%offset%)) + 'double-float)) + (* alpha temp2)))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)) + + (* alpha temp2)))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i m (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 zero) + (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) + (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%))))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)) + (* alpha temp2)))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)) + (* temp1 + (coerce (realpart + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) 'double-float)) + (* alpha temp2)))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (coerce (realpart + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)) 'double-float))) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)) + (* temp1 + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + (upper + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))) + (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + (upper + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zhemm fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame))));; + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zher2k BLAS} +%\pagehead{zher2k}{zher2k} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0) (zero (complex 0.0 0.0))) + (declare (type (double-float 1.0 1.0) one) (type (complex double-float) zero)) + (defun zher2k (uplo trans n k alpha a lda b ldb$ beta c ldc) + (declare (type (double-float) beta) + (type (array (complex double-float) (*)) c b a) + (type (complex double-float) alpha) + (type fixnum ldc ldb$ lda k n) + (type (simple-array character (*)) trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (b (complex double-float) b-%data% b-%offset%) + (c (complex double-float) c-%data% c-%offset%)) + (prog ((temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0)) (i 0) (info 0) (j 0) (l 0) + (nrowa 0) (upper nil)) + (declare (type (complex double-float) temp1 temp2) + (type fixnum i info j l nrowa) + (type (member t nil) upper)) + (cond + ((lsame trans "N") + (setf nrowa n)) + (t + (setf nrowa k))) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not upper) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) (not (lsame trans "C"))) + (setf info 2)) + ((< n 0) + (setf info 3)) + ((< k 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 7)) + ((< ldb$ + (max (the fixnum 1) (the fixnum nrowa))) + (setf info 9)) + ((< ldc (max (the fixnum 1) (the fixnum n))) + (setf info 12))) + (cond + ((/= info 0) + (xerbla "ZHER2K" info) + (go end_label))) + (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) + (go end_label)) + (cond + ((= alpha zero) + (cond + (upper + (cond + ((= beta (coerce (realpart zero) 'double-float)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float)) + '(complex double-float)))))))) + (t + (cond + ((= beta (coerce (realpart zero) 'double-float)) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float)) + '(complex double-float))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))))) + (go end_label))) + (cond + ((lsame trans "N") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta (coerce (realpart zero) 'double-float)) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float) + '(complex double-float))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) + (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + '(complex double-float))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%) + temp1) + (* + (f2cl-lib:fref b-%data% + (i l) + ((1 ldb$) (1 *)) + b-%offset%) + temp2))))) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%) + temp1) + (* + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%) + temp2))) 'double-float)) + '(complex double-float)))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta (coerce (realpart zero) 'double-float)) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%))' double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float) + '(complex double-float))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) + (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%)))) + (setf temp2 + (coerce + (f2cl-lib:dconjg + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + '(complex double-float))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%) + temp1) + (* + (f2cl-lib:fref b-%data% + (i l) + ((1 ldb$) (1 *)) + b-%offset%) + temp2))))) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float) + (coerce (realpart + (+ + (* + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%) + temp1) + (* + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%) + temp2))) 'double-float)) + '(complex double-float)))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf temp1 zero) + (setf temp2 zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp1 + (+ temp1 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref b-%data% + (l j) + ((1 ldb$) (1 *)) + b-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref b-%data% + (l i) + ((1 ldb$) (1 *)) + b-%offset%)) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= i j) + (cond + ((= beta (coerce (realpart zero) 'double-float)) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (coerce (realpart + (+ (* alpha temp1) + (* (f2cl-lib:dconjg alpha) temp2))) + 'double-float) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (+ + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) + 'double-float)) + (coerce (realpart + (+ (* alpha temp1) + (* (f2cl-lib:dconjg alpha) temp2))) + 'double-float)) + '(complex double-float)))))) + (t + (cond + ((= beta (coerce (realpart zero) 'double-float)) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp1) + (* (f2cl-lib:dconjg alpha) temp2)))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)) + (* alpha temp1) + (* (f2cl-lib:dconjg alpha) temp2)))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp1 zero) + (setf temp2 zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp1 + (+ temp1 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref b-%data% + (l j) + ((1 ldb$) (1 *)) + b-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:dconjg + (f2cl-lib:fref b-%data% + (l i) + ((1 ldb$) (1 *)) + b-%offset%)) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= i j) + (cond + ((= beta (coerce (realpart zero) 'double-float)) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (coerce (realpart + (+ (* alpha temp1) + (* (f2cl-lib:dconjg alpha) temp2))) + 'double-float) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (+ + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) + 'double-float)) + (coerce (realpart + (+ (* alpha temp1) + (* (f2cl-lib:dconjg alpha) temp2))) + 'double-float)) + '(complex double-float)))))) + (t + (cond + ((= beta (coerce (realpart zero) 'double-float)) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp1) + (* (f2cl-lib:dconjg alpha) temp2)))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)) + (* alpha temp1) + (* (f2cl-lib:dconjg alpha) temp2))))))))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zher2k +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum (double-float) +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame))));; + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zherk BLAS} +%\pagehead{zherk}{zherk} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one 1.0) (zero 0.0)) + (declare (type (double-float 1.0 1.0) one) + (type (double-float 0.0 0.0) zero)) + (defun zherk (uplo trans n k alpha a lda beta c ldc) + (declare (type (array (complex double-float) (*)) c a) + (type (double-float) beta alpha) + (type fixnum ldc lda k n) + (type (simple-array character (*)) trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (c (complex double-float) c-%data% c-%offset%)) + (prog ((temp #C(0.0 0.0)) (rtemp 0.0) (i 0) (info 0) (j 0) (l 0) + (nrowa 0) (upper nil)) + (declare (type (complex double-float) temp) + (type (double-float) rtemp) + (type fixnum i info j l nrowa) + (type (member t nil) upper)) + (cond + ((lsame trans "N") + (setf nrowa n)) + (t + (setf nrowa k))) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not upper) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) (not (lsame trans "C"))) + (setf info 2)) + ((< n 0) + (setf info 3)) + ((< k 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 7)) + ((< ldc (max (the fixnum 1) (the fixnum n))) + (setf info 10))) + (cond + ((/= info 0) + (xerbla "ZHERK " info) + (go end_label))) + (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) + (go end_label)) + (cond + ((= alpha zero) + (cond + (upper + (cond + ((= beta zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce zero '(complex double-float)))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float)) + '(complex double-float)))))))) + (t + (cond + ((= beta zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce zero '(complex double-float)))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float)) + '(complex double-float))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))))) + (go end_label))) + (cond + ((lsame trans "N") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce zero '(complex double-float)))))) + ((/= beta one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float)) + '(complex double-float)))) + (t + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float) + '(complex double-float))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) + (coerce (complex zero) '(complex double-float))) + (setf temp + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + '(complex double-float))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%)))))) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float) + (coerce (realpart + (* temp + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%))) + 'double-float)) + '(complex double-float)))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce zero '(complex double-float)))))) + ((/= beta one) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float)) + '(complex double-float))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)))))) + (t + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float) + '(complex double-float))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) + (coerce (complex zero) '(complex double-float))) + (setf temp + (coerce + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + '(complex double-float))) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (+ + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) 'double-float) + (coerce (realpart + (* temp + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + 'double-float)) + '(complex double-float))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%))))))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (setf temp (coerce zero '(complex double-float))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* alpha temp))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)))))))) + (setf rtemp zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf rtemp + (coerce + (realpart + (+ rtemp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))) + 'double-float)))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce (* alpha rtemp) '(complex double-float)))) + (t + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (+ (* alpha rtemp) + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) + 'double-float))) + '(complex double-float)))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf rtemp zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf rtemp + (coerce + (realpart + (+ rtemp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))) + 'double-float)))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce (* alpha rtemp) '(complex double-float)))) + (t + (setf (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%) + (coerce + (+ (* alpha rtemp) + (* beta + (coerce (realpart + (f2cl-lib:fref c-%data% + (j j) + ((1 ldc) (1 *)) + c-%offset%)) + 'double-float))) + '(complex double-float))))) + (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) + (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp (coerce zero '(complex double-float))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* alpha temp))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)))))))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zherk fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; (double-float) (array (complex double-float) (*)) +; fixnum (double-float) +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame))));; + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zsymm BLAS} +%\pagehead{zsymm}{zsymm} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zsymm (side uplo m n alpha a lda b ldb$ beta c ldc) + (declare (type (array (complex double-float) (*)) c b a) + (type (complex double-float) beta alpha) + (type fixnum ldc ldb$ lda n m) + (type (simple-array character (*)) uplo side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (uplo character uplo-%data% uplo-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (b (complex double-float) b-%data% b-%offset%) + (c (complex double-float) c-%data% c-%offset%)) + (prog ((temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0)) (i 0) (info 0) (j 0) (k 0) + (nrowa 0) (upper nil)) + (declare (type (complex double-float) temp1 temp2) + (type fixnum i info j k nrowa) + (type (member t nil) upper)) + (cond + ((lsame side "L") + (setf nrowa m)) + (t + (setf nrowa n))) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not (lsame side "L")) (not (lsame side "R"))) + (setf info 1)) + ((and (not upper) (not (lsame uplo "L"))) + (setf info 2)) + ((< m 0) + (setf info 3)) + ((< n 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 7)) + ((< ldb$ (max (the fixnum 1) (the fixnum m))) + (setf info 9)) + ((< ldc (max (the fixnum 1) (the fixnum m))) + (setf info 12))) + (cond + ((/= info 0) + (xerbla "ZSYMM " info) + (go end_label))) + (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one))) + (go end_label)) + (cond + ((= alpha zero) + (cond + ((= beta zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))) + (go end_label))) + (cond + ((lsame side "L") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 zero) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add i + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* temp1 + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)) + (* temp1 + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i m (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 zero) + (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) + (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (k j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* temp1 + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)) + (* temp1 + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)) + (* alpha temp2)))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))) + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (t + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)) + (* temp1 + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + (upper + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))) + (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + (upper + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp1 + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp1 + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zsymm fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame))));; + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zsyr2k BLAS} +%\pagehead{zsyr2k}{zsyr2k} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zsyr2k (uplo trans n k alpha a lda b ldb$ beta c ldc) + (declare (type (array (complex double-float) (*)) c b a) + (type (complex double-float) beta alpha) + (type fixnum ldc ldb$ lda k n) + (type (simple-array character (*)) trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (b (complex double-float) b-%data% b-%offset%) + (c (complex double-float) c-%data% c-%offset%)) + (prog ((temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0)) (i 0) (info 0) (j 0) (l 0) + (nrowa 0) (upper nil)) + (declare (type (complex double-float) temp1 temp2) + (type fixnum i info j l nrowa) + (type (member t nil) upper)) + (cond + ((lsame trans "N") + (setf nrowa n)) + (t + (setf nrowa k))) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not upper) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) (not (lsame trans "T"))) + (setf info 2)) + ((< n 0) + (setf info 3)) + ((< k 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 7)) + ((< ldb$ + (max (the fixnum 1) (the fixnum nrowa))) + (setf info 9)) + ((< ldc (max (the fixnum 1) (the fixnum n))) + (setf info 12))) + (cond + ((/= info 0) + (xerbla "ZSYR2K" info) + (go end_label))) + (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) + (go end_label)) + (cond + ((= alpha zero) + (cond + (upper + (cond + ((= beta zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)))))))))) + (t + (cond + ((= beta zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))))) + (go end_label))) + (cond + ((lsame trans "N") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) + (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%) + temp1) + (* + (f2cl-lib:fref b-%data% + (i l) + ((1 ldb$) (1 *)) + b-%offset%) + temp2)))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) + (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) + (setf temp1 + (* alpha + (f2cl-lib:fref b-%data% + (j l) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf temp2 + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%) + temp1) + (* + (f2cl-lib:fref b-%data% + (i l) + ((1 ldb$) (1 *)) + b-%offset%) + temp2)))))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf temp1 zero) + (setf temp2 zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp1 + (+ temp1 + (* + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (l j) + ((1 ldb$) (1 *)) + b-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (l i) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp1) (* alpha temp2)))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)) + (* alpha temp1) + (* alpha temp2)))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp1 zero) + (setf temp2 zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp1 + (+ temp1 + (* + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (l j) + ((1 ldb$) (1 *)) + b-%offset%)))) + (setf temp2 + (+ temp2 + (* + (f2cl-lib:fref b-%data% + (l i) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp1) (* alpha temp2)))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)) + (* alpha temp1) + (* alpha temp2))))))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zsyr2k +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))); + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{zsyrk BLAS} +%\pagehead{zsyrk}{zsyrk} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun zsyrk (uplo trans n k alpha a lda beta c ldc) + (declare (type (array (complex double-float) (*)) c a) + (type (complex double-float) beta alpha) + (type fixnum ldc lda k n) + (type (simple-array character (*)) trans uplo)) + (f2cl-lib:with-multi-array-data + ((uplo character uplo-%data% uplo-%offset%) + (trans character trans-%data% trans-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (c (complex double-float) c-%data% c-%offset%)) + (prog ((temp #C(0.0 0.0)) (i 0) (info 0) (j 0) (l 0) (nrowa 0) + (upper nil)) + (declare (type (complex double-float) temp) + (type fixnum i info j l nrowa) + (type (member t nil) upper)) + (cond + ((lsame trans "N") + (setf nrowa n)) + (t + (setf nrowa k))) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not upper) (not (lsame uplo "L"))) + (setf info 1)) + ((and (not (lsame trans "N")) (not (lsame trans "T"))) + (setf info 2)) + ((< n 0) + (setf info 3)) + ((< k 0) + (setf info 4)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 7)) + ((< ldc (max (the fixnum 1) (the fixnum n))) + (setf info 10))) + (cond + ((/= info 0) + (xerbla "ZSYRK " info) + (go end_label))) + (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) + (go end_label)) + (cond + ((= alpha zero) + (cond + (upper + (cond + ((= beta zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)))))))))) + (t + (cond + ((= beta zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))))) + (go end_label))) + (cond + ((lsame trans "N") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%))))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((= beta zero) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + zero)))) + ((/= beta one) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (j l) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i l) + ((1 lda) (1 *)) + a-%offset%))))))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i j) nil) + (tagbody + (setf temp zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* alpha temp))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) + ((> i n) nil) + (tagbody + (setf temp zero) + (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) + ((> l k) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (l i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref a-%data% + (l j) + ((1 lda) (1 *)) + a-%offset%)))))) + (cond + ((= beta zero) + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (* alpha temp))) + (t + (setf (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%) + (+ (* alpha temp) + (* beta + (f2cl-lib:fref c-%data% + (i j) + ((1 ldc) (1 *)) + c-%offset%)))))))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zsyrk fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ztrmm BLAS} +%\pagehead{ztrmm}{ztrmm} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun ztrmm (side uplo transa diag m n alpha a lda b ldb$) + (declare (type (array (complex double-float) (*)) b a) + (type (complex double-float) alpha) + (type fixnum ldb$ lda n m) + (type (simple-array character (*)) diag transa uplo side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (uplo character uplo-%data% uplo-%offset%) + (transa character transa-%data% transa-%offset%) + (diag character diag-%data% diag-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (b (complex double-float) b-%data% b-%offset%)) + (prog ((temp #C(0.0 0.0)) (i 0) (info 0) (j 0) (k 0) (nrowa 0) + (lside nil) (noconj nil) (nounit nil) (upper nil)) + (declare (type (complex double-float) temp) + (type fixnum i info j k nrowa) + (type (member t nil) lside noconj nounit upper)) + (setf lside (lsame side "L")) + (cond + (lside + (setf nrowa m)) + (t + (setf nrowa n))) + (setf noconj (lsame transa "T")) + (setf nounit (lsame diag "N")) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not lside) (not (lsame side "R"))) + (setf info 1)) + ((and (not upper) (not (lsame uplo "L"))) + (setf info 2)) + ((and (not (lsame transa "N")) + (not (lsame transa "T")) + (not (lsame transa "C"))) + (setf info 3)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 4)) + ((< m 0) + (setf info 5)) + ((< n 0) + (setf info 6)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 9)) + ((< ldb$ (max (the fixnum 1) (the fixnum m))) + (setf info 11))) + (cond + ((/= info 0) + (xerbla "ZTRMM " info) + (go end_label))) + (if (= n 0) (go end_label)) + (cond + ((= alpha zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + zero))))) + (go end_label))) + (cond + (lside + (cond + ((lsame transa "N") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add k + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (+ + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%)))))) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + temp)))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (k m + (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%))) + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + temp) + (if nounit + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add k 1) + (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (+ + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%))))))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i m + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add i + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add i + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))))) + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha temp))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)) + (cond + (noconj + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) + (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (t + (if nounit + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%))))) + (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) + (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (setf temp + (+ temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))))) + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha temp))))))))))) + (t + (cond + ((lsame transa "N") + (cond + (upper + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (setf temp alpha) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (+ + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (setf temp alpha) + (if nounit + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))) + (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) + (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (+ + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) + (cond + (noconj + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (+ + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (setf temp alpha) + (cond + (nounit + (cond + (noconj + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))))))) + (cond + ((/= temp one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (t + (f2cl-lib:fdo (k n (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k 1) nil) + (tagbody + (f2cl-lib:fdo (j (f2cl-lib:int-add k 1) + (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) + (cond + (noconj + (setf temp + (* alpha + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp + (* alpha + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (+ + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (setf temp alpha) + (cond + (nounit + (cond + (noconj + (setf temp + (* temp + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp + (* temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))))))) + (cond + ((/= temp one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::ztrmm fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{ztrsm BLAS} +%\pagehead{ztrsm}{ztrsm} +%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} + +<>= +(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) + (declare (type (complex double-float) one) (type (complex double-float) zero)) + (defun ztrsm (side uplo transa diag m n alpha a lda b ldb$) + (declare (type (array (complex double-float) (*)) b a) + (type (complex double-float) alpha) + (type fixnum ldb$ lda n m) + (type (simple-array character (*)) diag transa uplo side)) + (f2cl-lib:with-multi-array-data + ((side character side-%data% side-%offset%) + (uplo character uplo-%data% uplo-%offset%) + (transa character transa-%data% transa-%offset%) + (diag character diag-%data% diag-%offset%) + (a (complex double-float) a-%data% a-%offset%) + (b (complex double-float) b-%data% b-%offset%)) + (prog ((temp #C(0.0 0.0)) (i 0) (info 0) (j 0) (k 0) (nrowa 0) + (lside nil) (noconj nil) (nounit nil) (upper nil)) + (declare (type (complex double-float) temp) + (type fixnum i info j k nrowa) + (type (member t nil) lside noconj nounit upper)) + (setf lside (lsame side "L")) + (cond + (lside + (setf nrowa m)) + (t + (setf nrowa n))) + (setf noconj (lsame transa "T")) + (setf nounit (lsame diag "N")) + (setf upper (lsame uplo "U")) + (setf info 0) + (cond + ((and (not lside) (not (lsame side "R"))) + (setf info 1)) + ((and (not upper) (not (lsame uplo "L"))) + (setf info 2)) + ((and (not (lsame transa "N")) + (not (lsame transa "T")) + (not (lsame transa "C"))) + (setf info 3)) + ((and (not (lsame diag "U")) (not (lsame diag "N"))) + (setf info 4)) + ((< m 0) + (setf info 5)) + ((< n 0) + (setf info 6)) + ((< lda (max (the fixnum 1) (the fixnum nrowa))) + (setf info 9)) + ((< ldb$ (max (the fixnum 1) (the fixnum m))) + (setf info 11))) + (cond + ((/= info 0) + (xerbla "ZTRSM " info) + (go end_label))) + (if (= n 0) (go end_label)) + (cond + ((= alpha zero) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + zero))))) + (go end_label))) + (cond + (lside + (cond + ((lsame transa "N") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= alpha one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (k m + (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k 1) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) + (if nounit + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (/ + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i + (f2cl-lib:int-add k + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (- + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%))))))))))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= alpha one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) + (if nounit + (setf (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (/ + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (f2cl-lib:fdo (i (f2cl-lib:int-add k 1) + (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (- + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%) + (f2cl-lib:fref a-%data% + (i k) + ((1 lda) (1 *)) + a-%offset%))))))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (cond + (noconj + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add i + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add i + (f2cl-lib:int-sub + 1))) + nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + temp)))))) + (t + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (f2cl-lib:fdo (i m + (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) + ((> i 1) nil) + (tagbody + (setf temp + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))) + (cond + (noconj + (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) + (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%))))) + (t + (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) + (f2cl-lib:int-add k 1)) + ((> k m) nil) + (tagbody + (setf temp + (- temp + (* + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k i) + ((1 lda) (1 *)) + a-%offset%)) + (f2cl-lib:fref b-%data% + (k j) + ((1 ldb$) (1 *)) + b-%offset%)))))) + (if nounit + (setf temp + (/ temp + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (i i) + ((1 lda) (1 *)) + a-%offset%))))))) + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + temp)))))))))) + (t + (cond + ((lsame transa "N") + (cond + (upper + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= alpha one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k + (f2cl-lib:int-add j + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (- + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (cond + (nounit + (setf temp + (/ one + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (t + (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) + ((> j 1) nil) + (tagbody + (cond + ((/= alpha one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) + (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (- + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* + (f2cl-lib:fref a-%data% + (k j) + ((1 lda) (1 *)) + a-%offset%) + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (cond + (nounit + (setf temp + (/ one + (f2cl-lib:fref a-%data% + (j j) + ((1 lda) (1 *)) + a-%offset%))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%)))))))))))) + (t + (cond + (upper + (f2cl-lib:fdo (k n (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) + ((> k 1) nil) + (tagbody + (cond + (nounit + (cond + (noconj + (setf temp + (/ one + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp + (/ one + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) + ((> j + (f2cl-lib:int-add k + (f2cl-lib:int-sub 1))) + nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) + (cond + (noconj + (setf temp + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%))) + (t + (setf temp + (coerce + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)) + '(complex double-float))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (- + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (cond + ((/= alpha one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (t + (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) + ((> k n) nil) + (tagbody + (cond + (nounit + (cond + (noconj + (setf temp + (/ one + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))) + (t + (setf temp + (/ one + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (k k) + ((1 lda) (1 *)) + a-%offset%)))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))) + (f2cl-lib:fdo (j (f2cl-lib:int-add k 1) + (f2cl-lib:int-add j 1)) + ((> j n) nil) + (tagbody + (cond + ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) + (cond + (noconj + (setf temp + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%))) + (t + (setf temp + (coerce + (f2cl-lib:dconjg + (f2cl-lib:fref a-%data% + (j k) + ((1 lda) (1 *)) + a-%offset%)) + '(complex double-float))))) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (- + (f2cl-lib:fref b-%data% + (i j) + ((1 ldb$) (1 *)) + b-%offset%) + (* temp + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%)))))))))) + (cond + ((/= alpha one) + (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) + ((> i m) nil) + (tagbody + (setf (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%) + (* alpha + (f2cl-lib:fref b-%data% + (i k) + ((1 ldb$) (1 *)) + b-%offset%))))))))))))))) + end_label + (return (values nil nil nil nil nil nil nil nil nil nil nil)))))) + +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::ztrsm fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; ((complex double-float)) +; (array (complex double-float) (*)) +; fixnum +; (array (complex double-float) (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) + +@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\chapter{LAPACK} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dbdsdc LAPACK} -\pagehead{dbdsdc}{dbdsdc} +%\pagehead{dbdsdc}{dbdsdc} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} The input arguments are: @@ -2575,37 +21912,8 @@ The return values are: @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dcabs1 BLAS} -\pagehead{dcabs1}{dcabs1} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -The argument is: -\begin{itemize} -\item z - (complex double-float) -\end{itemize} - -The result is -\begin{itemize} -\item nil -\end{itemize} - -<>= -(defun dcabs1 (z) - (declare (type (complex double-float) z)) - (let ((dcabs1 0.0)) - (declare (type (double-float) dcabs1)) - (setf dcabs1 - (the double-float - (+ - (the double-float (abs - (the double-float (coerce (realpart z) 'double-float)))) - (the double-float (abs (f2cl-lib:dimag z)))))) - (values dcabs1 nil))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dbdsqr LAPACK} -\pagehead{dbdsqr}{dbdsqr} +%\pagehead{dbdsqr}{dbdsqr} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -3736,148 +23044,33 @@ The result is nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dbdsqr - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum fixnum - fixnum fixnum - (array double-float (*)) (array double-float (*)) - (array double-float (*)) fixnum - (array double-float (*)) fixnum - (array double-float (*)) fixnum - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil - nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dswap fortran-to-lisp::dscal - fortran-to-lisp::dlas2 fortran-to-lisp::drot - fortran-to-lisp::dlasv2 fortran-to-lisp::dlasr - fortran-to-lisp::dlartg fortran-to-lisp::dlamch - fortran-to-lisp::dlasq1 fortran-to-lisp::xerbla - fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dcopy BLAS} -\pagehead{dcopy}{dcopy} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(defun dcopy (n dx incx dy incy) - (declare (type (array double-float (*)) dy dx) - (type fixnum incy incx n)) - (f2cl-lib:with-multi-array-data - ((dx double-float dx-%data% dx-%offset%) - (dy double-float dy-%data% dy-%offset%)) - (prog ((i 0) (ix 0) (iy 0) (m 0) (mp1 0)) - (declare (type fixnum mp1 m iy ix i)) - (if (<= n 0) (go end_label)) - (if (and (= incx 1) (= incy 1)) (go label20)) - (setf ix 1) - (setf iy 1) - (if (< incx 0) - (setf ix - (f2cl-lib:int-add - (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) - 1))) - (if (< incy 0) - (setf iy - (f2cl-lib:int-add - (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) - 1))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%) - (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%)) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))) - (go end_label) - label20 - (setf m (mod n 7)) - (if (= m 0) (go label40)) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%) - (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)))) - (if (< n 7) (go end_label)) - label40 - (setf mp1 (f2cl-lib:int-add m 1)) - (f2cl-lib:fdo (i mp1 (f2cl-lib:int-add i 7)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%) - (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)) - (setf (f2cl-lib:fref dy-%data% - ((f2cl-lib:int-add i 1)) - ((1 *)) - dy-%offset%) - (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 1)) - ((1 *)) - dx-%offset%)) - (setf (f2cl-lib:fref dy-%data% - ((f2cl-lib:int-add i 2)) - ((1 *)) - dy-%offset%) - (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 2)) - ((1 *)) - dx-%offset%)) - (setf (f2cl-lib:fref dy-%data% - ((f2cl-lib:int-add i 3)) - ((1 *)) - dy-%offset%) - (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 3)) - ((1 *)) - dx-%offset%)) - (setf (f2cl-lib:fref dy-%data% - ((f2cl-lib:int-add i 4)) - ((1 *)) - dy-%offset%) - (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 4)) - ((1 *)) - dx-%offset%)) - (setf (f2cl-lib:fref dy-%data% - ((f2cl-lib:int-add i 5)) - ((1 *)) - dy-%offset%) - (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 5)) - ((1 *)) - dx-%offset%)) - (setf (f2cl-lib:fref dy-%data% - ((f2cl-lib:int-add i 6)) - ((1 *)) - dy-%offset%) - (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 6)) - ((1 *)) - dx-%offset%)))) - end_label - (return (values nil nil nil nil nil))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dcopy fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil) - :calls 'nil))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dbdsqr +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum fixnum +; fixnum fixnum +; (array double-float (*)) (array double-float (*)) +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil +; nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dswap fortran-to-lisp::dscal +; fortran-to-lisp::dlas2 fortran-to-lisp::drot +; fortran-to-lisp::dlasv2 fortran-to-lisp::dlasr +; fortran-to-lisp::dlartg fortran-to-lisp::dlamch +; fortran-to-lisp::dlasq1 fortran-to-lisp::xerbla +; fortran-to-lisp::lsame))));; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{ddisna LAPACK} -\pagehead{ddisna}{ddisna} +%\pagehead{ddisna}{ddisna} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -4027,436 +23220,24 @@ The result is end_label (return (values nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::ddisna - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum fixnum - (array double-float (*)) (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlamch fortran-to-lisp::xerbla - fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{ddot BLAS} -\pagehead{ddot}{ddot} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(defun ddot (n dx incx dy incy) - (declare (type (array double-float (*)) dy dx) - (type fixnum incy incx n)) - (f2cl-lib:with-multi-array-data - ((dx double-float dx-%data% dx-%offset%) - (dy double-float dy-%data% dy-%offset%)) - (prog ((i 0) (ix 0) (iy 0) (m 0) (mp1 0) (dtemp 0.0) (ddot 0.0)) - (declare (type (double-float) ddot dtemp) - (type fixnum mp1 m iy ix i)) - (setf ddot 0.0) - (setf dtemp 0.0) - (if (<= n 0) (go end_label)) - (if (and (= incx 1) (= incy 1)) (go label20)) - (setf ix 1) - (setf iy 1) - (if (< incx 0) - (setf ix - (f2cl-lib:int-add - (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) - 1))) - (if (< incy 0) - (setf iy - (f2cl-lib:int-add - (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) - 1))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf dtemp - (+ dtemp - (* (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%) - (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))) - (setf ddot dtemp) - (go end_label) - label20 - (setf m (mod n 5)) - (if (= m 0) (go label40)) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf dtemp - (+ dtemp - (* (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) - (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%)))))) - (if (< n 5) (go label60)) - label40 - (setf mp1 (f2cl-lib:int-add m 1)) - (f2cl-lib:fdo (i mp1 (f2cl-lib:int-add i 5)) - ((> i n) nil) - (tagbody - (setf dtemp - (+ dtemp - (* (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) - (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%)) - (* - (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 1)) - ((1 *)) - dx-%offset%) - (f2cl-lib:fref dy-%data% - ((f2cl-lib:int-add i 1)) - ((1 *)) - dy-%offset%)) - (* - (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 2)) - ((1 *)) - dx-%offset%) - (f2cl-lib:fref dy-%data% - ((f2cl-lib:int-add i 2)) - ((1 *)) - dy-%offset%)) - (* - (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 3)) - ((1 *)) - dx-%offset%) - (f2cl-lib:fref dy-%data% - ((f2cl-lib:int-add i 3)) - ((1 *)) - dy-%offset%)) - (* - (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 4)) - ((1 *)) - dx-%offset%) - (f2cl-lib:fref dy-%data% - ((f2cl-lib:int-add i 4)) - ((1 *)) - dy-%offset%)))))) - label60 - (setf ddot dtemp) - end_label - (return (values ddot nil nil nil nil nil))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::ddot fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil) - :calls 'nil))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dgbmv BLAS} -\pagehead{dgbmv}{dgbmv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one 1.0) (zero 0.0)) - (declare (type (double-float 1.0 1.0) one) - (type (double-float 0.0 0.0) zero)) - (defun dgbmv (trans m n kl ku alpha a lda x incx beta y incy) - (declare (type (array double-float (*)) y x a) - (type (double-float) beta alpha) - (type fixnum incy incx lda ku kl n m) - (type (simple-array character (*)) trans)) - (f2cl-lib:with-multi-array-data - ((trans character trans-%data% trans-%offset%) - (a double-float a-%data% a-%offset%) - (x double-float x-%data% x-%offset%) - (y double-float y-%data% y-%offset%)) - (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (k 0) (kup1 0) - (kx 0) (ky 0) (lenx 0) (leny 0) (temp 0.0)) - (declare (type fixnum i info ix iy j jx jy k kup1 kx ky - lenx leny) - (type (double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame trans "N")) - (not (lsame trans "T")) - (not (lsame trans "C"))) - (setf info 1)) - ((< m 0) - (setf info 2)) - ((< n 0) - (setf info 3)) - ((< kl 0) - (setf info 4)) - ((< ku 0) - (setf info 5)) - ((< lda (f2cl-lib:int-add kl ku 1)) - (setf info 8)) - ((= incx 0) - (setf info 10)) - ((= incy 0) - (setf info 13))) - (cond - ((/= info 0) - (xerbla "DGBMV " info) - (go end_label))) - (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one))) - (go end_label)) - (cond - ((lsame trans "N") - (setf lenx n) - (setf leny m)) - (t - (setf lenx m) - (setf leny n))) - (cond - ((> incx 0) - (setf kx 1)) - (t - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul - (f2cl-lib:int-sub lenx 1) - incx))))) - (cond - ((> incy 0) - (setf ky 1)) - (t - (setf ky - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul - (f2cl-lib:int-sub leny 1) - incy))))) - (cond - ((/= beta one) - (cond - ((= incy 1) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i leny) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - zero)))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i leny) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%)))))))) - (t - (setf iy ky) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i leny) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - zero) - (setf iy (f2cl-lib:int-add iy incy))))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i leny) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%))) - (setf iy (f2cl-lib:int-add iy incy)))))))))) - (if (= alpha zero) (go end_label)) - (setf kup1 (f2cl-lib:int-add ku 1)) - (cond - ((lsame trans "N") - (setf jx kx) - (cond - ((= incy 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - (setf k (f2cl-lib:int-sub kup1 j)) - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - ku)))) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum m) - (the fixnum - (f2cl-lib:int-add j kl)))) - nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add k i) j) - ((1 lda) (1 *)) - a-%offset%)))))))) - (setf jx (f2cl-lib:int-add jx incx))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - (setf iy ky) - (setf k (f2cl-lib:int-sub kup1 j)) - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - ku)))) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum m) - (the fixnum - (f2cl-lib:int-add j kl)))) - nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add k i) j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf iy (f2cl-lib:int-add iy incy)))))) - (setf jx (f2cl-lib:int-add jx incx)) - (if (> j ku) (setf ky (f2cl-lib:int-add ky incy)))))))) - (t - (setf jy ky) - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp zero) - (setf k (f2cl-lib:int-sub kup1 j)) - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - ku)))) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum m) - (the fixnum - (f2cl-lib:int-add j kl)))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add k i) j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* alpha temp))) - (setf jy (f2cl-lib:int-add jy incy))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp zero) - (setf ix kx) - (setf k (f2cl-lib:int-sub kup1 j)) - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - ku)))) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum m) - (the fixnum - (f2cl-lib:int-add j kl)))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add k i) j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* alpha temp))) - (setf jy (f2cl-lib:int-add jy incy)) - (if (> j ku) (setf kx (f2cl-lib:int-add kx incx))))))))) - end_label - (return - (values nil nil nil nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgbmv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum fixnum - fixnum fixnum - (double-float) (array double-float (*)) - fixnum (array double-float (*)) - fixnum (double-float) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil - nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::ddisna +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum fixnum +; (array double-float (*)) (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlamch fortran-to-lisp::xerbla +; fortran-to-lisp::lsame)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dgebak LAPACK} -\pagehead{dgebak}{dgebak} +%\pagehead{dgebak}{dgebak} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -4585,28 +23366,28 @@ The result is end_label (return (values nil nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgebak - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dswap fortran-to-lisp::dscal - fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgebak +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dswap fortran-to-lisp::dscal +; fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dgebal LAPACK} -\pagehead{dgebal}{dgebal} +%\pagehead{dgebal}{dgebal} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -4831,27 +23612,27 @@ The result is end_label (return (values nil nil nil nil ilo ihi nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgebal - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum (array double-float (*)) - fixnum fixnum - fixnum (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil fortran-to-lisp::ilo - fortran-to-lisp::ihi nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dscal fortran-to-lisp::idamax - fortran-to-lisp::dlamch fortran-to-lisp::dswap - fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgebal +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum (array double-float (*)) +; fixnum fixnum +; fixnum (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil fortran-to-lisp::ilo +; fortran-to-lisp::ihi nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dscal fortran-to-lisp::idamax +; fortran-to-lisp::dlamch fortran-to-lisp::dswap +; fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dgebd2 LAPACK} -\pagehead{dgebd2}{dgebd2} +%\pagehead{dgebd2}{dgebd2} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -5071,26 +23852,26 @@ The result is end_label (return (values nil nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgebd2 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (array double-float (*)) fixnum - (array double-float (*)) (array double-float (*)) - (array double-float (*)) (array double-float (*)) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlarf fortran-to-lisp::dlarfg - fortran-to-lisp::xerbla)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgebd2 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (array double-float (*)) fixnum +; (array double-float (*)) (array double-float (*)) +; (array double-float (*)) (array double-float (*)) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlarf fortran-to-lisp::dlarfg +; fortran-to-lisp::xerbla)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dgebrd LAPACK} -\pagehead{dgebrd}{dgebrd} +%\pagehead{dgebrd}{dgebrd} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -5272,28 +24053,28 @@ The result is end_label (return (values nil nil nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgebrd - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (array double-float (*)) fixnum - (array double-float (*)) (array double-float (*)) - (array double-float (*)) (array double-float (*)) - (array double-float (*)) fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dgebd2 fortran-to-lisp::dgemm - fortran-to-lisp::dlabrd fortran-to-lisp::xerbla - fortran-to-lisp::ilaenv)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgebrd +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (array double-float (*)) fixnum +; (array double-float (*)) (array double-float (*)) +; (array double-float (*)) (array double-float (*)) +; (array double-float (*)) fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dgebd2 fortran-to-lisp::dgemm +; fortran-to-lisp::dlabrd fortran-to-lisp::xerbla +; fortran-to-lisp::ilaenv)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dgeev LAPACK} -\pagehead{dgeev}{dgeev} +%\pagehead{dgeev}{dgeev} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -5824,37 +24605,37 @@ The result is (return (values nil nil nil nil nil nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgeev fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) (array double-float (*)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::drot fortran-to-lisp::dlartg - fortran-to-lisp::idamax fortran-to-lisp::dlapy2 - fortran-to-lisp::dscal fortran-to-lisp::dnrm2 - fortran-to-lisp::dgebak fortran-to-lisp::dtrevc - fortran-to-lisp::dhseqr fortran-to-lisp::dorghr - fortran-to-lisp::dlacpy fortran-to-lisp::dgehrd - fortran-to-lisp::dgebal fortran-to-lisp::dlascl - fortran-to-lisp::dlange fortran-to-lisp::dlabad - fortran-to-lisp::dlamch fortran-to-lisp::xerbla - fortran-to-lisp::ilaenv fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgeev fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::drot fortran-to-lisp::dlartg +; fortran-to-lisp::idamax fortran-to-lisp::dlapy2 +; fortran-to-lisp::dscal fortran-to-lisp::dnrm2 +; fortran-to-lisp::dgebak fortran-to-lisp::dtrevc +; fortran-to-lisp::dhseqr fortran-to-lisp::dorghr +; fortran-to-lisp::dlacpy fortran-to-lisp::dgehrd +; fortran-to-lisp::dgebal fortran-to-lisp::dlascl +; fortran-to-lisp::dlange fortran-to-lisp::dlabad +; fortran-to-lisp::dlamch fortran-to-lisp::xerbla +; fortran-to-lisp::ilaenv fortran-to-lisp::lsame)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dgeevx LAPACK} -\pagehead{dgeevx}{dgeevx} +%\pagehead{dgeevx}{dgeevx} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -6492,47 +25273,47 @@ The result is nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgeevx - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) (array double-float (*)) - fixnum (array double-float (*)) - fixnum fixnum - fixnum (array double-float (*)) - (double-float) (array double-float (*)) - (array double-float (*)) (array double-float (*)) - fixnum - (array fixnum (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::ilo fortran-to-lisp::ihi nil - fortran-to-lisp::abnrm nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dtrsna fortran-to-lisp::drot - fortran-to-lisp::dlartg fortran-to-lisp::idamax - fortran-to-lisp::dlapy2 fortran-to-lisp::dscal - fortran-to-lisp::dnrm2 fortran-to-lisp::dgebak - fortran-to-lisp::dtrevc fortran-to-lisp::dhseqr - fortran-to-lisp::dorghr fortran-to-lisp::dlacpy - fortran-to-lisp::dgehrd fortran-to-lisp::dgebal - fortran-to-lisp::dlascl fortran-to-lisp::dlange - fortran-to-lisp::dlabad fortran-to-lisp::dlamch - fortran-to-lisp::xerbla fortran-to-lisp::ilaenv - fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgeevx +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum fixnum +; fixnum (array double-float (*)) +; (double-float) (array double-float (*)) +; (array double-float (*)) (array double-float (*)) +; fixnum +; (array fixnum (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::ilo fortran-to-lisp::ihi nil +; fortran-to-lisp::abnrm nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dtrsna fortran-to-lisp::drot +; fortran-to-lisp::dlartg fortran-to-lisp::idamax +; fortran-to-lisp::dlapy2 fortran-to-lisp::dscal +; fortran-to-lisp::dnrm2 fortran-to-lisp::dgebak +; fortran-to-lisp::dtrevc fortran-to-lisp::dhseqr +; fortran-to-lisp::dorghr fortran-to-lisp::dlacpy +; fortran-to-lisp::dgehrd fortran-to-lisp::dgebal +; fortran-to-lisp::dlascl fortran-to-lisp::dlange +; fortran-to-lisp::dlabad fortran-to-lisp::dlamch +; fortran-to-lisp::xerbla fortran-to-lisp::ilaenv +; fortran-to-lisp::lsame)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dgehd2 LAPACK} -\pagehead{dgehd2}{dgehd2} +%\pagehead{dgehd2}{dgehd2} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -6620,24 +25401,24 @@ The result is end_label (return (values nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgehd2 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlarf fortran-to-lisp::dlarfg - fortran-to-lisp::xerbla)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgehd2 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlarf fortran-to-lisp::dlarfg +; fortran-to-lisp::xerbla)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dgehrd LAPACK} -\pagehead{dgehrd}{dgehrd} +%\pagehead{dgehrd}{dgehrd} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -6814,27 +25595,27 @@ The result is end_label (return (values nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgehrd - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dgehd2 fortran-to-lisp::dlarfb - fortran-to-lisp::dgemm fortran-to-lisp::dlahrd - fortran-to-lisp::xerbla fortran-to-lisp::ilaenv)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgehrd +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dgehd2 fortran-to-lisp::dlarfb +; fortran-to-lisp::dgemm fortran-to-lisp::dlahrd +; fortran-to-lisp::xerbla fortran-to-lisp::ilaenv)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dgelq2 LAPACK} -\pagehead{dgelq2}{dgelq2} +%\pagehead{dgelq2}{dgelq2} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -6904,24 +25685,24 @@ The result is end_label (return (values nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgelq2 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (array double-float (*)) fixnum - (array double-float (*)) (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlarf fortran-to-lisp::dlarfg - fortran-to-lisp::xerbla)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgelq2 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (array double-float (*)) fixnum +; (array double-float (*)) (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlarf fortran-to-lisp::dlarfg +; fortran-to-lisp::xerbla)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dgelqf LAPACK} -\pagehead{dgelqf}{dgelqf} +%\pagehead{dgelqf}{dgelqf} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -7037,582 +25818,26 @@ The result is end_label (return (values nil nil nil nil nil nil nil info))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgelqf - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (array double-float (*)) fixnum - (array double-float (*)) (array double-float (*)) - fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlarfb fortran-to-lisp::dlarft - fortran-to-lisp::dgelq2 fortran-to-lisp::xerbla - fortran-to-lisp::ilaenv)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dgemm BLAS} -\pagehead{dgemm}{dgemm} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one 1.0) (zero 0.0)) - (declare (type (double-float 1.0 1.0) one) - (type (double-float 0.0 0.0) zero)) - (defun dgemm (transa transb m n k alpha a lda b ldb$ beta c ldc) - (declare (type (array double-float (*)) c b a) - (type (double-float) beta alpha) - (type fixnum ldc ldb$ lda k n m) - (type (simple-array character (*)) transb transa)) - (f2cl-lib:with-multi-array-data - ((transa character transa-%data% transa-%offset%) - (transb character transb-%data% transb-%offset%) - (a double-float a-%data% a-%offset%) - (b double-float b-%data% b-%offset%) - (c double-float c-%data% c-%offset%)) - (prog ((temp 0.0) (i 0) (info 0) (j 0) (l 0) (ncola 0) (nrowa 0) - (nrowb 0) (nota nil) (notb nil)) - (declare (type (double-float) temp) - (type fixnum i info j l ncola nrowa nrowb) - (type (member t nil) nota notb)) - (setf nota (lsame transa "N")) - (setf notb (lsame transb "N")) - (cond - (nota - (setf nrowa m) - (setf ncola k)) - (t - (setf nrowa k) - (setf ncola m))) - (cond - (notb - (setf nrowb k)) - (t - (setf nrowb n))) - (setf info 0) - (cond - ((and (not nota) (not (lsame transa "C")) (not (lsame transa "T"))) - (setf info 1)) - ((and (not notb) (not (lsame transb "C")) (not (lsame transb "T"))) - (setf info 2)) - ((< m 0) - (setf info 3)) - ((< n 0) - (setf info 4)) - ((< k 0) - (setf info 5)) - ((< lda (max (the fixnum 1) (the fixnum nrowa))) - (setf info 8)) - ((< ldb$ - (max (the fixnum 1) (the fixnum nrowb))) - (setf info 10)) - ((< ldc (max (the fixnum 1) (the fixnum m))) - (setf info 13))) - (cond - ((/= info 0) - (xerbla "DGEMM " info) - (go end_label))) - (if (or (= m 0) (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) - (go end_label)) - (cond - ((= alpha zero) - (cond - ((= beta zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))))) - (go end_label))) - (cond - (notb - (cond - (nota - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))) - ((/= beta one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref b (l j) ((1 ldb$) (1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref b-%data% - (l j) - ((1 ldb$) (1 *)) - b-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i l) - ((1 lda) (1 *)) - a-%offset%))))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (l j) - ((1 ldb$) (1 *)) - b-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* alpha temp))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))))))))) - (t - (cond - (nota - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))) - ((/= beta one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref b-%data% - (j l) - ((1 ldb$) (1 *)) - b-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i l) - ((1 lda) (1 *)) - a-%offset%))))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (j l) - ((1 ldb$) (1 *)) - b-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* alpha temp))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)))))))))))))) - end_label - (return - (values nil nil nil nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgemm fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - fixnum (double-float) - (array double-float (*)) fixnum - (array double-float (*)) fixnum - (double-float) (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil - nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dgemv BLAS} -\pagehead{dgemv}{dgemv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one 1.0) (zero 0.0)) - (declare (type (double-float 1.0 1.0) one) - (type (double-float 0.0 0.0) zero)) - (defun dgemv (trans m n alpha a lda x incx beta y incy) - (declare (type (array double-float (*)) y x a) - (type (double-float) beta alpha) - (type fixnum incy incx lda n m) - (type (simple-array character (*)) trans)) - (f2cl-lib:with-multi-array-data - ((trans character trans-%data% trans-%offset%) - (a double-float a-%data% a-%offset%) - (x double-float x-%data% x-%offset%) - (y double-float y-%data% y-%offset%)) - (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (kx 0) (ky 0) - (lenx 0) (leny 0) (temp 0.0)) - (declare (type fixnum i info ix iy j jx jy kx ky lenx - leny) - (type (double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame trans "N")) - (not (lsame trans "T")) - (not (lsame trans "C"))) - (setf info 1)) - ((< m 0) - (setf info 2)) - ((< n 0) - (setf info 3)) - ((< lda (max (the fixnum 1) (the fixnum m))) - (setf info 6)) - ((= incx 0) - (setf info 8)) - ((= incy 0) - (setf info 11))) - (cond - ((/= info 0) - (xerbla "DGEMV " info) - (go end_label))) - (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one))) - (go end_label)) - (cond - ((lsame trans "N") - (setf lenx n) - (setf leny m)) - (t - (setf lenx m) - (setf leny n))) - (cond - ((> incx 0) - (setf kx 1)) - (t - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul - (f2cl-lib:int-sub lenx 1) - incx))))) - (cond - ((> incy 0) - (setf ky 1)) - (t - (setf ky - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul - (f2cl-lib:int-sub leny 1) - incy))))) - (cond - ((/= beta one) - (cond - ((= incy 1) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i leny) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - zero)))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i leny) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%)))))))) - (t - (setf iy ky) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i leny) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - zero) - (setf iy (f2cl-lib:int-add iy incy))))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i leny) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%))) - (setf iy (f2cl-lib:int-add iy incy)))))))))) - (if (= alpha zero) (go end_label)) - (cond - ((lsame trans "N") - (setf jx kx) - (cond - ((= incy 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))))))) - (setf jx (f2cl-lib:int-add jx incx))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - (setf iy ky) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf iy (f2cl-lib:int-add iy incy)))))) - (setf jx (f2cl-lib:int-add jx incx))))))) - (t - (setf jy ky) - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* alpha temp))) - (setf jy (f2cl-lib:int-add jy incy))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp zero) - (setf ix kx) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* alpha temp))) - (setf jy (f2cl-lib:int-add jy incy)))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgemv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum fixnum - (double-float) (array double-float (*)) - fixnum (array double-float (*)) - fixnum (double-float) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgelqf +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (array double-float (*)) fixnum +; (array double-float (*)) (array double-float (*)) +; fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlarfb fortran-to-lisp::dlarft +; fortran-to-lisp::dgelq2 fortran-to-lisp::xerbla +; fortran-to-lisp::ilaenv)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dgeqr2 LAPACK} -\pagehead{dgeqr2}{dgeqr2} +%\pagehead{dgeqr2}{dgeqr2} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -7678,24 +25903,24 @@ The result is end_label (return (values nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgeqr2 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (array double-float (*)) fixnum - (array double-float (*)) (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlarf fortran-to-lisp::dlarfg - fortran-to-lisp::xerbla)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgeqr2 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (array double-float (*)) fixnum +; (array double-float (*)) (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlarf fortran-to-lisp::dlarfg +; fortran-to-lisp::xerbla))));;; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dgeqrf LAPACK} -\pagehead{dgeqrf}{dgeqrf} +%\pagehead{dgeqrf}{dgeqrf} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -7811,152 +26036,26 @@ The result is end_label (return (values nil nil nil nil nil nil nil info))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgeqrf - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (array double-float (*)) fixnum - (array double-float (*)) (array double-float (*)) - fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlarfb fortran-to-lisp::dlarft - fortran-to-lisp::dgeqr2 fortran-to-lisp::xerbla - fortran-to-lisp::ilaenv)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dger BLAS} -\pagehead{dger}{dger} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero 0.0)) - (declare (type (double-float 0.0 0.0) zero)) - (defun dger (m n alpha x incx y incy a lda) - (declare (type (array double-float (*)) a y x) - (type (double-float) alpha) - (type fixnum lda incy incx n m)) - (f2cl-lib:with-multi-array-data - ((x double-float x-%data% x-%offset%) - (y double-float y-%data% y-%offset%) - (a double-float a-%data% a-%offset%)) - (prog ((i 0) (info 0) (ix 0) (j 0) (jy 0) (kx 0) (temp 0.0)) - (declare (type fixnum i info ix j jy kx) - (type (double-float) temp)) - (setf info 0) - (cond - ((< m 0) - (setf info 1)) - ((< n 0) - (setf info 2)) - ((= incx 0) - (setf info 5)) - ((= incy 0) - (setf info 7)) - ((< lda (max (the fixnum 1) (the fixnum m))) - (setf info 9))) - (cond - ((/= info 0) - (xerbla "DGER " info) - (go end_label))) - (if (or (= m 0) (= n 0) (= alpha zero)) (go end_label)) - (cond - ((> incy 0) - (setf jy 1)) - (t - (setf jy - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incy))))) - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref y (jy) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%) - temp))))))) - (setf jy (f2cl-lib:int-add jy incy))))) - (t - (cond - ((> incx 0) - (setf kx 1)) - (t - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul - (f2cl-lib:int-sub m 1) - incx))))) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref y (jy) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%))) - (setf ix kx) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - temp))) - (setf ix (f2cl-lib:int-add ix incx)))))) - (setf jy (f2cl-lib:int-add jy incy)))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dger fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (double-float) (array double-float (*)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgeqrf +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (array double-float (*)) fixnum +; (array double-float (*)) (array double-float (*)) +; fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlarfb fortran-to-lisp::dlarft +; fortran-to-lisp::dgeqr2 fortran-to-lisp::xerbla +; fortran-to-lisp::ilaenv)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dgesdd LAPACK} -\pagehead{dgesdd}{dgesdd} +%\pagehead{dgesdd}{dgesdd} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -9962,37 +28061,37 @@ The result is (return (values nil nil nil nil nil nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgesdd - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum fixnum - (array double-float (*)) fixnum - (array double-float (*)) (array double-float (*)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum - (array fixnum (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dorglq fortran-to-lisp::dgelqf - fortran-to-lisp::dorgbr fortran-to-lisp::dgemm - fortran-to-lisp::dormbr fortran-to-lisp::dorgqr - fortran-to-lisp::dlacpy fortran-to-lisp::dbdsdc - fortran-to-lisp::dgebrd fortran-to-lisp::dlaset - fortran-to-lisp::dgeqrf fortran-to-lisp::dlascl - fortran-to-lisp::dlange fortran-to-lisp::dlamch - fortran-to-lisp::xerbla fortran-to-lisp::ilaenv - fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgesdd +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum fixnum +; (array double-float (*)) fixnum +; (array double-float (*)) (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum +; (array fixnum (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dorglq fortran-to-lisp::dgelqf +; fortran-to-lisp::dorgbr fortran-to-lisp::dgemm +; fortran-to-lisp::dormbr fortran-to-lisp::dorgqr +; fortran-to-lisp::dlacpy fortran-to-lisp::dbdsdc +; fortran-to-lisp::dgebrd fortran-to-lisp::dlaset +; fortran-to-lisp::dgeqrf fortran-to-lisp::dlascl +; fortran-to-lisp::dlange fortran-to-lisp::dlamch +; fortran-to-lisp::xerbla fortran-to-lisp::ilaenv +; fortran-to-lisp::lsame))));; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dgesvd LAPACK} -\pagehead{dgesvd}{dgesvd} +%\pagehead{dgesvd}{dgesvd} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -16388,37 +34487,37 @@ The result is (return (values nil nil nil nil nil nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgesvd - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - (array double-float (*)) fixnum - (array double-float (*)) (array double-float (*)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dorglq fortran-to-lisp::dgelqf - fortran-to-lisp::dormbr fortran-to-lisp::dgemm - fortran-to-lisp::dorgqr fortran-to-lisp::dlacpy - fortran-to-lisp::dbdsqr fortran-to-lisp::dorgbr - fortran-to-lisp::dgebrd fortran-to-lisp::dlaset - fortran-to-lisp::dgeqrf fortran-to-lisp::dlascl - fortran-to-lisp::dlange fortran-to-lisp::dlamch - fortran-to-lisp::xerbla fortran-to-lisp::lsame - fortran-to-lisp::ilaenv)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgesvd +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; (array double-float (*)) fixnum +; (array double-float (*)) (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dorglq fortran-to-lisp::dgelqf +; fortran-to-lisp::dormbr fortran-to-lisp::dgemm +; fortran-to-lisp::dorgqr fortran-to-lisp::dlacpy +; fortran-to-lisp::dbdsqr fortran-to-lisp::dorgbr +; fortran-to-lisp::dgebrd fortran-to-lisp::dlaset +; fortran-to-lisp::dgeqrf fortran-to-lisp::dlascl +; fortran-to-lisp::dlange fortran-to-lisp::dlamch +; fortran-to-lisp::xerbla fortran-to-lisp::lsame +; fortran-to-lisp::ilaenv))));; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dgesv LAPACK} -\pagehead{dgesv}{dgesv} +%\pagehead{dgesv}{dgesv} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -16461,24 +34560,24 @@ The result is end_label (return (values nil nil nil nil nil nil nil info))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgesv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (array double-float (*)) fixnum - (array fixnum (*)) - (array double-float (*)) fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dgetrs fortran-to-lisp::dgetrf - fortran-to-lisp::xerbla)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgesv fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (array double-float (*)) fixnum +; (array fixnum (*)) +; (array double-float (*)) fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dgetrs fortran-to-lisp::dgetrf +; fortran-to-lisp::xerbla))));;; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dgetf2 LAPACK} -\pagehead{dgetf2}{dgetf2} +%\pagehead{dgetf2}{dgetf2} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -16571,25 +34670,25 @@ The result is end_label (return (values nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgetf2 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (array double-float (*)) fixnum - (array fixnum (*)) - fixnum) - :return-values '(nil nil nil nil nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dger fortran-to-lisp::dscal - fortran-to-lisp::dswap fortran-to-lisp::idamax - fortran-to-lisp::xerbla)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgetf2 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (array double-float (*)) fixnum +; (array fixnum (*)) +; fixnum) +; :return-values '(nil nil nil nil nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dger fortran-to-lisp::dscal +; fortran-to-lisp::dswap fortran-to-lisp::idamax +; fortran-to-lisp::xerbla))));; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dgetrf LAPACK} -\pagehead{dgetrf}{dgetrf} +%\pagehead{dgetrf}{dgetrf} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -16711,25 +34810,25 @@ The result is end_label (return (values nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgetrf - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (array double-float (*)) fixnum - (array fixnum (*)) - fixnum) - :return-values '(nil nil nil nil nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dgemm fortran-to-lisp::dtrsm - fortran-to-lisp::dlaswp fortran-to-lisp::dgetf2 - fortran-to-lisp::ilaenv fortran-to-lisp::xerbla)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgetrf +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (array double-float (*)) fixnum +; (array fixnum (*)) +; fixnum) +; :return-values '(nil nil nil nil nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dgemm fortran-to-lisp::dtrsm +; fortran-to-lisp::dlaswp fortran-to-lisp::dgetf2 +; fortran-to-lisp::ilaenv fortran-to-lisp::xerbla))));; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dgetrs LAPACK} -\pagehead{dgetrs}{dgetrs} +%\pagehead{dgetrs}{dgetrs} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -16779,27 +34878,27 @@ The result is end_label (return (values nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dgetrs - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum fixnum - (array double-float (*)) fixnum - (array fixnum (*)) - (array double-float (*)) fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dtrsm fortran-to-lisp::dlaswp - fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dgetrs +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum fixnum +; (array double-float (*)) fixnum +; (array fixnum (*)) +; (array double-float (*)) fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dtrsm fortran-to-lisp::dlaswp +; fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dhseqr LAPACK} -\pagehead{dhseqr}{dhseqr} +%\pagehead{dhseqr}{dhseqr} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -17255,36 +35354,36 @@ The result is (return (values nil nil nil nil nil nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dhseqr - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) (array double-float (*)) - fixnum (array double-float (*)) - fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlarfx fortran-to-lisp::dlarfg - fortran-to-lisp::dlapy2 fortran-to-lisp::dscal - fortran-to-lisp::idamax fortran-to-lisp::dgemv - fortran-to-lisp::dcopy fortran-to-lisp::dlacpy - fortran-to-lisp::dlanhs fortran-to-lisp::dlabad - fortran-to-lisp::dlamch fortran-to-lisp::dlahqr - fortran-to-lisp::ilaenv fortran-to-lisp::dlaset - fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dhseqr +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlarfx fortran-to-lisp::dlarfg +; fortran-to-lisp::dlapy2 fortran-to-lisp::dscal +; fortran-to-lisp::idamax fortran-to-lisp::dgemv +; fortran-to-lisp::dcopy fortran-to-lisp::dlacpy +; fortran-to-lisp::dlanhs fortran-to-lisp::dlabad +; fortran-to-lisp::dlamch fortran-to-lisp::dlahqr +; fortran-to-lisp::ilaenv fortran-to-lisp::dlaset +; fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlabad LAPACK} -\pagehead{dlabad}{dlabad} +%\pagehead{dlabad}{dlabad} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -17298,20 +35397,20 @@ The result is (setf large (f2cl-lib:fsqrt large)))) (return (values small large)))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlabad - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((double-float) (double-float)) - :return-values '(fortran-to-lisp::small fortran-to-lisp::large) - :calls 'nil))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlabad +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((double-float) (double-float)) +; :return-values '(fortran-to-lisp::small fortran-to-lisp::large) +; :calls 'nil))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlabrd LAPACK} -\pagehead{dlabrd}{dlabrd} +%\pagehead{dlabrd}{dlabrd} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -17839,28 +35938,28 @@ The result is (return (values nil nil nil nil nil nil nil nil nil nil nil nil nil)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlabrd - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) (array double-float (*)) - (array double-float (*)) (array double-float (*)) - fixnum (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil - nil) - :calls '(fortran-to-lisp::dscal fortran-to-lisp::dlarfg - fortran-to-lisp::dgemv)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlabrd +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) (array double-float (*)) +; (array double-float (*)) (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil +; nil) +; :calls '(fortran-to-lisp::dscal fortran-to-lisp::dlarfg +; fortran-to-lisp::dgemv)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlacon LAPACK} -\pagehead{dlacon}{dlacon} +%\pagehead{dlacon}{dlacon} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -18011,25 +36110,25 @@ The result is end_label (return (values nil nil nil nil est kase))))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlacon - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum (array double-float (*)) - (array double-float (*)) - (array fixnum (*)) (double-float) - fixnum) - :return-values '(nil nil nil nil fortran-to-lisp::est - fortran-to-lisp::kase) - :calls '(fortran-to-lisp::dcopy fortran-to-lisp::idamax - fortran-to-lisp::dasum)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlacon +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum (array double-float (*)) +; (array double-float (*)) +; (array fixnum (*)) (double-float) +; fixnum) +; :return-values '(nil nil nil nil fortran-to-lisp::est +; fortran-to-lisp::kase) +; :calls '(fortran-to-lisp::dcopy fortran-to-lisp::idamax +; fortran-to-lisp::dasum))));; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlacpy LAPACK} -\pagehead{dlacpy}{dlacpy} +%\pagehead{dlacpy}{dlacpy} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -18095,23 +36194,23 @@ The result is end_label (return (values nil nil nil nil nil nil nil))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlacpy - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum fixnum - (array double-float (*)) fixnum - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlacpy +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum fixnum +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::lsame)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dladiv LAPACK} -\pagehead{dladiv}{dladiv} +%\pagehead{dladiv}{dladiv} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -18132,22 +36231,22 @@ The result is (setf q (/ (- (* b e) a) f)))) (return (values nil nil nil nil p q)))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dladiv - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((double-float) (double-float) (double-float) - (double-float) (double-float) (double-float)) - :return-values '(nil nil nil nil fortran-to-lisp::p - fortran-to-lisp::q) - :calls 'nil))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dladiv +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((double-float) (double-float) (double-float) +; (double-float) (double-float) (double-float)) +; :return-values '(nil nil nil nil fortran-to-lisp::p +; fortran-to-lisp::q) +; :calls 'nil))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlaed6 LAPACK} -\pagehead{dlaed6}{dlaed6} +%\pagehead{dlaed6}{dlaed6} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -18461,24 +36560,24 @@ The result is end_label (return (values nil nil nil nil nil nil tau info))))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlaed6 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum (member t nil) - (double-float) (array double-float (3)) - (array double-float (3)) (double-float) (double-float) - fixnum) - :return-values '(nil nil nil nil nil nil fortran-to-lisp::tau - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlamch)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlaed6 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum (member t nil) +; (double-float) (array double-float (3)) +; (array double-float (3)) (double-float) (double-float) +; fixnum) +; :return-values '(nil nil nil nil nil nil fortran-to-lisp::tau +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlamch)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlaexc LAPACK} -\pagehead{dlaexc}{dlaexc} +%\pagehead{dlaexc}{dlaexc} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -18952,30 +37051,30 @@ The result is end_label (return (values nil nil nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlaexc - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((member t nil) fixnum - (array double-float (*)) fixnum - (array double-float (*)) fixnum - fixnum fixnum - fixnum (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlanv2 fortran-to-lisp::dlarfx - fortran-to-lisp::dlarfg fortran-to-lisp::dlasy2 - fortran-to-lisp::dlamch fortran-to-lisp::dlange - fortran-to-lisp::dlacpy fortran-to-lisp::drot - fortran-to-lisp::dlartg)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlaexc +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((member t nil) fixnum +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum +; fixnum fixnum +; fixnum (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlanv2 fortran-to-lisp::dlarfx +; fortran-to-lisp::dlarfg fortran-to-lisp::dlasy2 +; fortran-to-lisp::dlamch fortran-to-lisp::dlange +; fortran-to-lisp::dlacpy fortran-to-lisp::drot +; fortran-to-lisp::dlartg)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlahqr LAPACK} -\pagehead{dlahqr}{dlahqr} +%\pagehead{dlahqr}{dlahqr} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -19641,31 +37740,31 @@ The result is (return (values nil nil nil nil nil nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlahqr - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((member t nil) (member t nil) - fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum - fixnum (array double-float (*)) - fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::drot fortran-to-lisp::dlanv2 - fortran-to-lisp::dlarfg fortran-to-lisp::dcopy - fortran-to-lisp::dlanhs fortran-to-lisp::dlabad - fortran-to-lisp::dlamch)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlahqr +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((member t nil) (member t nil) +; fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum +; fixnum (array double-float (*)) +; fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::drot fortran-to-lisp::dlanv2 +; fortran-to-lisp::dlarfg fortran-to-lisp::dcopy +; fortran-to-lisp::dlanhs fortran-to-lisp::dlabad +; fortran-to-lisp::dlamch)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlahrd LAPACK} -\pagehead{dlahrd}{dlahrd} +%\pagehead{dlahrd}{dlahrd} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -19835,26 +37934,26 @@ The result is end_label (return (values nil nil nil nil nil nil nil nil nil nil)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlahrd - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::dscal fortran-to-lisp::dlarfg - fortran-to-lisp::daxpy fortran-to-lisp::dtrmv - fortran-to-lisp::dcopy fortran-to-lisp::dgemv)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlahrd +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::dscal fortran-to-lisp::dlarfg +; fortran-to-lisp::daxpy fortran-to-lisp::dtrmv +; fortran-to-lisp::dcopy fortran-to-lisp::dgemv)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlaln2 LAPACK} -\pagehead{dlaln2}{dlaln2} +%\pagehead{dlaln2}{dlaln2} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -20558,30 +38657,30 @@ The result is xnorm info))))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlaln2 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((member t nil) fixnum - fixnum (double-float) - (double-float) (array double-float (*)) - fixnum (double-float) - (double-float) (array double-float (*)) - fixnum (double-float) - (double-float) (array double-float (*)) - fixnum (double-float) - (double-float) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil fortran-to-lisp::scale - fortran-to-lisp::xnorm fortran-to-lisp::info) - :calls '(fortran-to-lisp::dladiv fortran-to-lisp::dlamch)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlaln2 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((member t nil) fixnum +; fixnum (double-float) +; (double-float) (array double-float (*)) +; fixnum (double-float) +; (double-float) (array double-float (*)) +; fixnum (double-float) +; (double-float) (array double-float (*)) +; fixnum (double-float) +; (double-float) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil +; nil nil fortran-to-lisp::scale +; fortran-to-lisp::xnorm fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dladiv fortran-to-lisp::dlamch)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlamch LAPACK} -\pagehead{dlamch}{dlamch} +%\pagehead{dlamch}{dlamch} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -20669,20 +38768,20 @@ The result is end_label (return (values dlamch nil))))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlamch - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1))) - :return-values '(nil) - :calls '(fortran-to-lisp::dlamc2 fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlamch +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1))) +; :return-values '(nil) +; :calls '(fortran-to-lisp::dlamc2 fortran-to-lisp::lsame))));;; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlamc1 LAPACK} -\pagehead{dlamc1}{dlamc1} +%\pagehead{dlamc1}{dlamc1} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -20815,22 +38914,22 @@ The result is end_label (return (values beta t$ rnd ieee1))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlamc1 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (member t nil) (member t nil)) - :return-values '(fortran-to-lisp::beta fortran-to-lisp::t$ - fortran-to-lisp::rnd fortran-to-lisp::ieee1) - :calls '(fortran-to-lisp::dlamc3)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlamc1 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (member t nil) (member t nil)) +; :return-values '(fortran-to-lisp::beta fortran-to-lisp::t$ +; fortran-to-lisp::rnd fortran-to-lisp::ieee1) +; :calls '(fortran-to-lisp::dlamc3)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlamc2 LAPACK} -\pagehead{dlamc2}{dlamc2} +%\pagehead{dlamc2}{dlamc2} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -21072,27 +39171,27 @@ The result is end_label (return (values beta t$ rnd eps emin rmin emax rmax))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlamc2 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (member t nil) (double-float) - fixnum (double-float) - fixnum (double-float)) - :return-values '(fortran-to-lisp::beta fortran-to-lisp::t$ - fortran-to-lisp::rnd fortran-to-lisp::eps - fortran-to-lisp::emin fortran-to-lisp::rmin - fortran-to-lisp::emax fortran-to-lisp::rmax) - :calls '(fortran-to-lisp::dlamc5 fortran-to-lisp::dlamc4 - fortran-to-lisp::dlamc3 fortran-to-lisp::dlamc1)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlamc2 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (member t nil) (double-float) +; fixnum (double-float) +; fixnum (double-float)) +; :return-values '(fortran-to-lisp::beta fortran-to-lisp::t$ +; fortran-to-lisp::rnd fortran-to-lisp::eps +; fortran-to-lisp::emin fortran-to-lisp::rmin +; fortran-to-lisp::emax fortran-to-lisp::rmax) +; :calls '(fortran-to-lisp::dlamc5 fortran-to-lisp::dlamc4 +; fortran-to-lisp::dlamc3 fortran-to-lisp::dlamc1)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlamc3 LAPACK} -\pagehead{dlamc3}{dlamc3} +%\pagehead{dlamc3}{dlamc3} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -21103,20 +39202,20 @@ The result is (setf dlamc3 (+ a b)) (return (values dlamc3 a b)))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlamc3 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((double-float) (double-float)) - :return-values '(fortran-to-lisp::a fortran-to-lisp::b) - :calls 'nil))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlamc3 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((double-float) (double-float)) +; :return-values '(fortran-to-lisp::a fortran-to-lisp::b) +; :calls 'nil))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlamc4 LAPACK} -\pagehead{dlamc4}{dlamc4} +%\pagehead{dlamc4}{dlamc4} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -21182,21 +39281,21 @@ The result is end_label (return (values emin nil nil)))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlamc4 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum (double-float) - fixnum) - :return-values '(fortran-to-lisp::emin nil nil) - :calls '(fortran-to-lisp::dlamc3)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlamc4 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum (double-float) +; fixnum) +; :return-values '(fortran-to-lisp::emin nil nil) +; :calls '(fortran-to-lisp::dlamc3))));; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlamc5 LAPACK} -\pagehead{dlamc5}{dlamc5} +%\pagehead{dlamc5}{dlamc5} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -21269,24 +39368,24 @@ The result is end_label (return (values beta nil emin ieee emax rmax))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlamc5 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - fixnum (member t nil) - fixnum (double-float)) - :return-values '(fortran-to-lisp::beta nil fortran-to-lisp::emin - fortran-to-lisp::ieee fortran-to-lisp::emax - fortran-to-lisp::rmax) - :calls '(fortran-to-lisp::dlamc3)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlamc5 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; fixnum (member t nil) +; fixnum (double-float)) +; :return-values '(fortran-to-lisp::beta nil fortran-to-lisp::emin +; fortran-to-lisp::ieee fortran-to-lisp::emax +; fortran-to-lisp::rmax) +; :calls '(fortran-to-lisp::dlamc3))));;; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlamrg LAPACK} -\pagehead{dlamrg}{dlamrg} +%\pagehead{dlamrg}{dlamrg} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -21346,23 +39445,23 @@ The result is end_label (return (values nil nil nil nil nil nil))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlamrg - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (array double-float (*)) fixnum - fixnum - (array fixnum (*))) - :return-values '(nil nil nil nil nil nil) - :calls 'nil))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlamrg +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (array double-float (*)) fixnum +; fixnum +; (array fixnum (*))) +; :return-values '(nil nil nil nil nil nil) +; :calls 'nil))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlange LAPACK} -\pagehead{dlange}{dlange} +%\pagehead{dlange}{dlange} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -21466,23 +39565,23 @@ The result is end_label (return (values dlange nil nil nil nil nil nil)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlange - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum fixnum - (array double-float (*)) fixnum - (array double-float (*))) - :return-values '(nil nil nil nil nil nil) - :calls '(fortran-to-lisp::dlassq fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlange +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum fixnum +; (array double-float (*)) fixnum +; (array double-float (*))) +; :return-values '(nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::dlassq fortran-to-lisp::lsame)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlanhs LAPACK} -\pagehead{dlanhs}{dlanhs} +%\pagehead{dlanhs}{dlanhs} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -21600,22 +39699,22 @@ The result is end_label (return (values dlanhs nil nil nil nil nil)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlanhs - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum (array double-float (*)) - fixnum (array double-float (*))) - :return-values '(nil nil nil nil nil) - :calls '(fortran-to-lisp::dlassq fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlanhs +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*))) +; :return-values '(nil nil nil nil nil) +; :calls '(fortran-to-lisp::dlassq fortran-to-lisp::lsame)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlanst LAPACK} -\pagehead{dlanst}{dlanst} +%\pagehead{dlanst}{dlanst} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -21710,22 +39809,22 @@ The result is end_label (return (values dlanst nil nil nil nil)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlanst - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum (array double-float (*)) - (array double-float (*))) - :return-values '(nil nil nil nil) - :calls '(fortran-to-lisp::dlassq fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlanst +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum (array double-float (*)) +; (array double-float (*))) +; :return-values '(nil nil nil nil) +; :calls '(fortran-to-lisp::dlassq fortran-to-lisp::lsame)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlanv2 LAPACK} -\pagehead{dlanv2}{dlanv2} +%\pagehead{dlanv2}{dlanv2} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -21839,27 +39938,27 @@ The result is end_label (return (values a b c d rt1r rt1i rt2r rt2i cs sn))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlanv2 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((double-float) (double-float) (double-float) - (double-float) (double-float) (double-float) - (double-float) (double-float) (double-float) - (double-float)) - :return-values '(fortran-to-lisp::a fortran-to-lisp::b - fortran-to-lisp::c fortran-to-lisp::d - fortran-to-lisp::rt1r fortran-to-lisp::rt1i - fortran-to-lisp::rt2r fortran-to-lisp::rt2i - fortran-to-lisp::cs fortran-to-lisp::sn) - :calls '(fortran-to-lisp::dlapy2 fortran-to-lisp::dlamch)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlanv2 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((double-float) (double-float) (double-float) +; (double-float) (double-float) (double-float) +; (double-float) (double-float) (double-float) +; (double-float)) +; :return-values '(fortran-to-lisp::a fortran-to-lisp::b +; fortran-to-lisp::c fortran-to-lisp::d +; fortran-to-lisp::rt1r fortran-to-lisp::rt1i +; fortran-to-lisp::rt2r fortran-to-lisp::rt2i +; fortran-to-lisp::cs fortran-to-lisp::sn) +; :calls '(fortran-to-lisp::dlapy2 fortran-to-lisp::dlamch)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlapy2 LAPACK} -\pagehead{dlapy2}{dlapy2} +%\pagehead{dlapy2}{dlapy2} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -21881,20 +39980,20 @@ The result is (setf dlapy2 (* w (f2cl-lib:fsqrt (+ one (expt (/ z w) 2))))))) (return (values dlapy2 nil nil))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlapy2 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((double-float) (double-float)) - :return-values '(nil nil) - :calls 'nil))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlapy2 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((double-float) (double-float)) +; :return-values '(nil nil) +; :calls 'nil))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlaqtr LAPACK} -\pagehead{dlaqtr}{dlaqtr} +%\pagehead{dlaqtr}{dlaqtr} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -23033,29 +41132,29 @@ The result is end_label (return (values nil nil nil nil nil nil nil scale nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlaqtr - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((member t nil) (member t nil) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (double-float) (double-float) (array double-float (*)) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::scale - nil nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dladiv fortran-to-lisp::ddot - fortran-to-lisp::dlaln2 fortran-to-lisp::daxpy - fortran-to-lisp::dscal fortran-to-lisp::idamax - fortran-to-lisp::dasum fortran-to-lisp::dlange - fortran-to-lisp::dlamch)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlaqtr +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((member t nil) (member t nil) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (double-float) (double-float) (array double-float (*)) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::scale +; nil nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dladiv fortran-to-lisp::ddot +; fortran-to-lisp::dlaln2 fortran-to-lisp::daxpy +; fortran-to-lisp::dscal fortran-to-lisp::idamax +; fortran-to-lisp::dasum fortran-to-lisp::dlange +; fortran-to-lisp::dlamch))));; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlarfb LAPACK} -\pagehead{dlarfb}{dlarfb} +%\pagehead{dlarfb}{dlarfb} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -23655,31 +41754,31 @@ The result is nil nil)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlarfb - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil) - :calls '(fortran-to-lisp::dgemm fortran-to-lisp::dtrmm - fortran-to-lisp::dcopy fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlarfb +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil +; nil nil) +; :calls '(fortran-to-lisp::dgemm fortran-to-lisp::dtrmm +; fortran-to-lisp::dcopy fortran-to-lisp::lsame)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlarfg LAPACK} -\pagehead{dlarfg}{dlarfg} +%\pagehead{dlarfg}{dlarfg} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -23732,24 +41831,24 @@ The result is end_label (return (values nil alpha nil nil tau)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlarfg - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum (double-float) - (array double-float (*)) fixnum - (double-float)) - :return-values '(nil fortran-to-lisp::alpha nil nil - fortran-to-lisp::tau) - :calls '(fortran-to-lisp::dscal fortran-to-lisp::dlamch - fortran-to-lisp::dlapy2 fortran-to-lisp::dnrm2)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlarfg +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum (double-float) +; (array double-float (*)) fixnum +; (double-float)) +; :return-values '(nil fortran-to-lisp::alpha nil nil +; fortran-to-lisp::tau) +; :calls '(fortran-to-lisp::dscal fortran-to-lisp::dlamch +; fortran-to-lisp::dlapy2 fortran-to-lisp::dnrm2)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlarf LAPACK} -\pagehead{dlarf}{dlarf} +%\pagehead{dlarf}{dlarf} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -23781,24 +41880,24 @@ The result is (dger m n (- tau) work 1 v incv c ldc))))) (return (values nil nil nil nil nil nil nil nil nil)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlarf fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum fixnum - (array double-float (*)) fixnum - (double-float) (array double-float (*)) - fixnum (array double-float (*))) - :return-values '(nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::dger fortran-to-lisp::dgemv - fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlarf fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum fixnum +; (array double-float (*)) fixnum +; (double-float) (array double-float (*)) +; fixnum (array double-float (*))) +; :return-values '(nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::dger fortran-to-lisp::dgemv +; fortran-to-lisp::lsame))));;; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlarft LAPACK} -\pagehead{dlarft}{dlarft} +%\pagehead{dlarft}{dlarft} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -24031,26 +42130,26 @@ The result is end_label (return (values nil nil nil nil nil nil nil nil nil)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlarft - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - (array double-float (*)) fixnum - (array double-float (*)) (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::dtrmv fortran-to-lisp::dgemv - fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlarft +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; (array double-float (*)) fixnum +; (array double-float (*)) (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::dtrmv fortran-to-lisp::dgemv +; fortran-to-lisp::lsame)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlarfx LAPACK} -\pagehead{dlarfx}{dlarfx} +%\pagehead{dlarfx}{dlarfx} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -26097,25 +44196,25 @@ The result is end_label (return (values nil nil nil nil nil nil nil nil)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlarfx - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum fixnum - (array double-float (*)) (double-float) - (array double-float (*)) fixnum - (array double-float (*))) - :return-values '(nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::dger fortran-to-lisp::dgemv - fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlarfx +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum fixnum +; (array double-float (*)) (double-float) +; (array double-float (*)) fixnum +; (array double-float (*))) +; :return-values '(nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::dger fortran-to-lisp::dgemv +; fortran-to-lisp::lsame))));; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlartg LAPACK} -\pagehead{dlartg}{dlartg} +%\pagehead{dlartg}{dlartg} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -26201,22 +44300,22 @@ The result is end_label (return (values nil nil cs sn r)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlartg - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((double-float) (double-float) (double-float) - (double-float) (double-float)) - :return-values '(nil nil fortran-to-lisp::cs fortran-to-lisp::sn - fortran-to-lisp::r) - :calls '(fortran-to-lisp::dlamch)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlartg +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((double-float) (double-float) (double-float) +; (double-float) (double-float)) +; :return-values '(nil nil fortran-to-lisp::cs fortran-to-lisp::sn +; fortran-to-lisp::r) +; :calls '(fortran-to-lisp::dlamch)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlas2 LAPACK} -\pagehead{dlas2}{dlas2} +%\pagehead{dlas2}{dlas2} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -26275,21 +44374,21 @@ The result is (setf ssmax (/ ga (+ c c))))))))) (return (values nil nil nil ssmin ssmax))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlas2 fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((double-float) (double-float) (double-float) - (double-float) (double-float)) - :return-values '(nil nil nil fortran-to-lisp::ssmin - fortran-to-lisp::ssmax) - :calls 'nil))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlas2 fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((double-float) (double-float) (double-float) +; (double-float) (double-float)) +; :return-values '(nil nil nil fortran-to-lisp::ssmin +; fortran-to-lisp::ssmax) +; :calls 'nil)));; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlascl LAPACK} -\pagehead{dlascl}{dlascl} +%\pagehead{dlascl}{dlascl} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -26550,27 +44649,27 @@ The result is end_label (return (values nil nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlascl - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum fixnum - (double-float) (double-float) - fixnum fixnum - (array double-float (*)) fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlamch fortran-to-lisp::xerbla - fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlascl +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum fixnum +; (double-float) (double-float) +; fixnum fixnum +; (array double-float (*)) fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlamch fortran-to-lisp::xerbla +; fortran-to-lisp::lsame)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasd0 LAPACK} -\pagehead{dlasd0}{dlasd0} +%\pagehead{dlasd0}{dlasd0} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -26801,28 +44900,28 @@ The result is end_label (return (values nil nil nil nil nil nil nil nil nil nil nil info))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasd0 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (array double-float (*)) (array double-float (*)) - (array double-float (*)) fixnum - (array double-float (*)) fixnum - fixnum - (array fixnum (*)) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlasd1 fortran-to-lisp::dlasdt - fortran-to-lisp::dlasdq fortran-to-lisp::xerbla)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasd0 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (array double-float (*)) (array double-float (*)) +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum +; fixnum +; (array fixnum (*)) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlasd1 fortran-to-lisp::dlasdt +; fortran-to-lisp::dlasdq fortran-to-lisp::xerbla))));;; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasd1 LAPACK} -\pagehead{dlasd1}{dlasd1} +%\pagehead{dlasd1}{dlasd1} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -26959,31 +45058,31 @@ The result is nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasd1 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - fixnum (array double-float (*)) - (double-float) (double-float) (array double-float (*)) - fixnum (array double-float (*)) - fixnum - (array fixnum (*)) - (array fixnum (*)) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil fortran-to-lisp::alpha - fortran-to-lisp::beta nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlamrg fortran-to-lisp::dlasd3 - fortran-to-lisp::dlasd2 fortran-to-lisp::dlascl - fortran-to-lisp::xerbla)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasd1 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; fixnum (array double-float (*)) +; (double-float) (double-float) (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum +; (array fixnum (*)) +; (array fixnum (*)) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil fortran-to-lisp::alpha +; fortran-to-lisp::beta nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlamrg fortran-to-lisp::dlasd3 +; fortran-to-lisp::dlasd2 fortran-to-lisp::dlascl +; fortran-to-lisp::xerbla)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasd2 LAPACK} -\pagehead{dlasd2}{dlasd2} +%\pagehead{dlasd2}{dlasd2} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -27463,38 +45562,38 @@ The result is nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasd2 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - fixnum fixnum - (array double-float (*)) (array double-float (*)) - (double-float) (double-float) (array double-float (*)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum - (array double-float (*)) fixnum - (array fixnum (*)) - (array fixnum (*)) - (array fixnum (*)) - (array fixnum (*)) - (array fixnum (*)) - fixnum) - :return-values '(nil nil nil fortran-to-lisp::k nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlacpy fortran-to-lisp::dlaset - fortran-to-lisp::dcopy fortran-to-lisp::drot - fortran-to-lisp::dlapy2 fortran-to-lisp::dlamch - fortran-to-lisp::dlamrg fortran-to-lisp::xerbla)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasd2 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; fixnum fixnum +; (array double-float (*)) (array double-float (*)) +; (double-float) (double-float) (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum +; (array fixnum (*)) +; (array fixnum (*)) +; (array fixnum (*)) +; (array fixnum (*)) +; (array fixnum (*)) +; fixnum) +; :return-values '(nil nil nil fortran-to-lisp::k nil nil nil nil nil +; nil nil nil nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlacpy fortran-to-lisp::dlaset +; fortran-to-lisp::dcopy fortran-to-lisp::drot +; fortran-to-lisp::dlapy2 fortran-to-lisp::dlamch +; fortran-to-lisp::dlamrg fortran-to-lisp::xerbla)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasd3 LAPACK} -\pagehead{dlasd3}{dlasd3} +%\pagehead{dlasd3}{dlasd3} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -27994,34 +46093,34 @@ The result is nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasd3 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - fixnum fixnum - (array double-float (*)) (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum - (array double-float (*)) fixnum - (array double-float (*)) fixnum - (array double-float (*)) fixnum - (array fixnum (*)) - (array fixnum (*)) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlacpy fortran-to-lisp::dgemm - fortran-to-lisp::dlasd4 fortran-to-lisp::dlascl - fortran-to-lisp::dnrm2 fortran-to-lisp::dlamc3 - fortran-to-lisp::dcopy fortran-to-lisp::xerbla)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasd3 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; fixnum fixnum +; (array double-float (*)) (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum +; (array fixnum (*)) +; (array fixnum (*)) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil +; nil nil nil nil nil nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlacpy fortran-to-lisp::dgemm +; fortran-to-lisp::dlasd4 fortran-to-lisp::dlascl +; fortran-to-lisp::dnrm2 fortran-to-lisp::dlamc3 +; fortran-to-lisp::dcopy fortran-to-lisp::xerbla)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasd4 LAPACK} -\pagehead{dlasd4}{dlasd4} +%\pagehead{dlasd4}{dlasd4} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -29548,25 +47647,25 @@ The result is end_label (return (values nil nil nil nil nil nil sigma nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasd4 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (array double-float (*)) (array double-float (*)) - (array double-float (*)) (double-float) (double-float) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil fortran-to-lisp::sigma nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlaed6 fortran-to-lisp::dlamch - fortran-to-lisp::dlasd5)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasd4 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (array double-float (*)) (array double-float (*)) +; (array double-float (*)) (double-float) (double-float) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil fortran-to-lisp::sigma nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlaed6 fortran-to-lisp::dlamch +; fortran-to-lisp::dlasd5))));; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasd5 LAPACK} -\pagehead{dlasd5}{dlasd5} +%\pagehead{dlasd5}{dlasd5} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -29772,22 +47871,22 @@ The result is tau)))) (return (values nil nil nil nil nil dsigma nil)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasd5 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum (array double-float (2)) - (array double-float (2)) (array double-float (2)) - (double-float) (double-float) (array double-float (2))) - :return-values '(nil nil nil nil nil fortran-to-lisp::dsigma nil) - :calls 'nil))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasd5 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum (array double-float (2)) +; (array double-float (2)) (array double-float (2)) +; (double-float) (double-float) (array double-float (2))) +; :return-values '(nil nil nil nil nil fortran-to-lisp::dsigma nil) +; :calls 'nil))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasd6 LAPACK} -\pagehead{dlasd6}{dlasd6} +%\pagehead{dlasd6}{dlasd6} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -29945,40 +48044,40 @@ The result is nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasd6 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - fixnum fixnum - (array double-float (*)) (array double-float (*)) - (array double-float (*)) (double-float) (double-float) - (array fixnum (*)) - (array fixnum (*)) - fixnum - (array fixnum (*)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) (array double-float (*)) - (array double-float (*)) fixnum - (double-float) (double-float) (array double-float (*)) - (array fixnum (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::alpha - fortran-to-lisp::beta nil nil - fortran-to-lisp::givptr nil nil nil nil nil nil nil - nil fortran-to-lisp::k fortran-to-lisp::c - fortran-to-lisp::s nil nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlamrg fortran-to-lisp::dcopy - fortran-to-lisp::dlasd8 fortran-to-lisp::dlasd7 - fortran-to-lisp::dlascl fortran-to-lisp::xerbla)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasd6 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; fixnum fixnum +; (array double-float (*)) (array double-float (*)) +; (array double-float (*)) (double-float) (double-float) +; (array fixnum (*)) +; (array fixnum (*)) +; fixnum +; (array fixnum (*)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) (array double-float (*)) +; (array double-float (*)) fixnum +; (double-float) (double-float) (array double-float (*)) +; (array fixnum (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::alpha +; fortran-to-lisp::beta nil nil +; fortran-to-lisp::givptr nil nil nil nil nil nil nil +; nil fortran-to-lisp::k fortran-to-lisp::c +; fortran-to-lisp::s nil nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlamrg fortran-to-lisp::dcopy +; fortran-to-lisp::dlasd8 fortran-to-lisp::dlasd7 +; fortran-to-lisp::dlascl fortran-to-lisp::xerbla))));;; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasd7 LAPACK} -\pagehead{dlasd7}{dlasd7} +%\pagehead{dlasd7}{dlasd7} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -30348,41 +48447,41 @@ The result is s info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasd7 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - fixnum fixnum - fixnum (array double-float (*)) - (array double-float (*)) (array double-float (*)) - (array double-float (*)) (array double-float (*)) - (array double-float (*)) (array double-float (*)) - (double-float) (double-float) (array double-float (*)) - (array fixnum (*)) - (array fixnum (*)) - (array fixnum (*)) - (array fixnum (*)) - fixnum - (array fixnum (*)) - fixnum (array double-float (*)) - fixnum (double-float) - (double-float) fixnum) - :return-values '(nil nil nil nil fortran-to-lisp::k nil nil nil nil - nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::givptr nil nil nil nil - fortran-to-lisp::c fortran-to-lisp::s - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dcopy fortran-to-lisp::drot - fortran-to-lisp::dlapy2 fortran-to-lisp::dlamch - fortran-to-lisp::dlamrg fortran-to-lisp::xerbla)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasd7 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; fixnum fixnum +; fixnum (array double-float (*)) +; (array double-float (*)) (array double-float (*)) +; (array double-float (*)) (array double-float (*)) +; (array double-float (*)) (array double-float (*)) +; (double-float) (double-float) (array double-float (*)) +; (array fixnum (*)) +; (array fixnum (*)) +; (array fixnum (*)) +; (array fixnum (*)) +; fixnum +; (array fixnum (*)) +; fixnum (array double-float (*)) +; fixnum (double-float) +; (double-float) fixnum) +; :return-values '(nil nil nil nil fortran-to-lisp::k nil nil nil nil +; nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::givptr nil nil nil nil +; fortran-to-lisp::c fortran-to-lisp::s +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dcopy fortran-to-lisp::drot +; fortran-to-lisp::dlapy2 fortran-to-lisp::dlamch +; fortran-to-lisp::dlamrg fortran-to-lisp::xerbla))));; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasd8 LAPACK} -\pagehead{dlasd8}{dlasd8} +%\pagehead{dlasd8}{dlasd8} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -30723,29 +48822,29 @@ The result is end_label (return (values nil nil nil nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasd8 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (array double-float (*)) (array double-float (*)) - (array double-float (*)) (array double-float (*)) - (array double-float (*)) (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dcopy fortran-to-lisp::ddot - fortran-to-lisp::dlasd4 fortran-to-lisp::dlaset - fortran-to-lisp::dlascl fortran-to-lisp::dnrm2 - fortran-to-lisp::dlamc3 fortran-to-lisp::xerbla)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasd8 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (array double-float (*)) (array double-float (*)) +; (array double-float (*)) (array double-float (*)) +; (array double-float (*)) (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dcopy fortran-to-lisp::ddot +; fortran-to-lisp::dlasd4 fortran-to-lisp::dlaset +; fortran-to-lisp::dlascl fortran-to-lisp::dnrm2 +; fortran-to-lisp::dlamc3 fortran-to-lisp::xerbla))));; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasda LAPACK} -\pagehead{dlasda}{dlasda} +%\pagehead{dlasda}{dlasda} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -31266,39 +49365,39 @@ The result is nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasda - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - fixnum fixnum - (array double-float (*)) (array double-float (*)) - (array double-float (*)) fixnum - (array double-float (*)) - (array fixnum (*)) - (array double-float (*)) (array double-float (*)) - (array double-float (*)) (array double-float (*)) - (array fixnum (*)) - (array fixnum (*)) - fixnum - (array fixnum (*)) - (array double-float (*)) (array double-float (*)) - (array double-float (*)) (array double-float (*)) - (array fixnum (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlasdt fortran-to-lisp::dlasd6 - fortran-to-lisp::dcopy fortran-to-lisp::dlaset - fortran-to-lisp::dlasdq fortran-to-lisp::xerbla)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasda +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; fixnum fixnum +; (array double-float (*)) (array double-float (*)) +; (array double-float (*)) fixnum +; (array double-float (*)) +; (array fixnum (*)) +; (array double-float (*)) (array double-float (*)) +; (array double-float (*)) (array double-float (*)) +; (array fixnum (*)) +; (array fixnum (*)) +; fixnum +; (array fixnum (*)) +; (array double-float (*)) (array double-float (*)) +; (array double-float (*)) (array double-float (*)) +; (array fixnum (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil +; nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlasdt fortran-to-lisp::dlasd6 +; fortran-to-lisp::dcopy fortran-to-lisp::dlaset +; fortran-to-lisp::dlasdq fortran-to-lisp::xerbla)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasdq LAPACK} -\pagehead{dlasdq}{dlasdq} +%\pagehead{dlasdq}{dlasdq} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -31574,31 +49673,31 @@ The result is nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasdq - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum fixnum - fixnum fixnum - fixnum (array double-float (*)) - (array double-float (*)) (array double-float (*)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil - nil nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dswap fortran-to-lisp::dbdsqr - fortran-to-lisp::dlasr fortran-to-lisp::dlartg - fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasdq +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum fixnum +; fixnum fixnum +; fixnum (array double-float (*)) +; (array double-float (*)) (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil +; nil nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dswap fortran-to-lisp::dbdsqr +; fortran-to-lisp::dlasr fortran-to-lisp::dlartg +; fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasdt LAPACK} -\pagehead{dlasdt}{dlasdt} +%\pagehead{dlasdt}{dlasdt} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -31707,26 +49806,26 @@ The result is end_label (return (values nil lvl nd nil nil nil nil)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasdt - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - fixnum - (array fixnum (*)) - (array fixnum (*)) - (array fixnum (*)) - fixnum) - :return-values '(nil fortran-to-lisp::lvl fortran-to-lisp::nd nil - nil nil nil) - :calls 'nil))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasdt +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; fixnum +; (array fixnum (*)) +; (array fixnum (*)) +; (array fixnum (*)) +; fixnum) +; :return-values '(nil fortran-to-lisp::lvl fortran-to-lisp::nd nil +; nil nil nil) +; :calls 'nil))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlaset LAPACK} -\pagehead{dlaset}{dlaset} +%\pagehead{dlaset}{dlaset} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -31794,23 +49893,23 @@ The result is (setf (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) a-%offset%) beta))) (return (values nil nil nil nil nil nil nil))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlaset - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum fixnum - (double-float) (double-float) (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlaset +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum fixnum +; (double-float) (double-float) (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::lsame)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasq1 LAPACK} -\pagehead{dlasq1}{dlasq1} +%\pagehead{dlasq1}{dlasq1} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -31924,25 +50023,25 @@ The result is end_label (return (values nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasq1 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum (array double-float (*)) - (array double-float (*)) (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlasq2 fortran-to-lisp::dlascl - fortran-to-lisp::dcopy fortran-to-lisp::dlamch - fortran-to-lisp::dlasrt fortran-to-lisp::dlas2 - fortran-to-lisp::xerbla)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasq1 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum (array double-float (*)) +; (array double-float (*)) (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlasq2 fortran-to-lisp::dlascl +; fortran-to-lisp::dcopy fortran-to-lisp::dlamch +; fortran-to-lisp::dlasrt fortran-to-lisp::dlas2 +; fortran-to-lisp::xerbla))));; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasq2 LAPACK} -\pagehead{dlasq2}{dlasq2} +%\pagehead{dlasq2}{dlasq2} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -32803,23 +50902,23 @@ The result is end_label (return (values nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasq2 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum (array double-float (*)) - fixnum) - :return-values '(nil nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlasq3 fortran-to-lisp::ilaenv - fortran-to-lisp::dlasrt fortran-to-lisp::xerbla - fortran-to-lisp::dlamch)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasq2 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum (array double-float (*)) +; fixnum) +; :return-values '(nil nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlasq3 fortran-to-lisp::ilaenv +; fortran-to-lisp::dlasrt fortran-to-lisp::xerbla +; fortran-to-lisp::dlamch)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasq3 LAPACK} -\pagehead{dlasq3}{dlasq3} +%\pagehead{dlasq3}{dlasq3} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -33423,30 +51522,30 @@ The result is ndiv nil))))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasq3 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (array double-float (*)) fixnum - (double-float) (double-float) (double-float) - (double-float) fixnum - fixnum fixnum - (member t nil)) - :return-values '(nil fortran-to-lisp::n0 nil nil - fortran-to-lisp::dmin fortran-to-lisp::sigma - fortran-to-lisp::desig fortran-to-lisp::qmax - fortran-to-lisp::nfail fortran-to-lisp::iter - fortran-to-lisp::ndiv nil) - :calls '(fortran-to-lisp::dlasq6 fortran-to-lisp::dlasq5 - fortran-to-lisp::dlasq4 fortran-to-lisp::dlamch)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasq3 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (array double-float (*)) fixnum +; (double-float) (double-float) (double-float) +; (double-float) fixnum +; fixnum fixnum +; (member t nil)) +; :return-values '(nil fortran-to-lisp::n0 nil nil +; fortran-to-lisp::dmin fortran-to-lisp::sigma +; fortran-to-lisp::desig fortran-to-lisp::qmax +; fortran-to-lisp::nfail fortran-to-lisp::iter +; fortran-to-lisp::ndiv nil) +; :calls '(fortran-to-lisp::dlasq6 fortran-to-lisp::dlasq5 +; fortran-to-lisp::dlasq4 fortran-to-lisp::dlamch)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasq4 LAPACK} -\pagehead{dlasq4}{dlasq4} +%\pagehead{dlasq4}{dlasq4} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -33968,26 +52067,26 @@ The result is (return (values nil nil nil nil nil nil nil nil nil nil nil tau ttype))))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasq4 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (array double-float (*)) fixnum - fixnum (double-float) - (double-float) (double-float) (double-float) - (double-float) (double-float) (double-float) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::tau fortran-to-lisp::ttype) - :calls 'nil))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasq4 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (array double-float (*)) fixnum +; fixnum (double-float) +; (double-float) (double-float) (double-float) +; (double-float) (double-float) (double-float) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::tau fortran-to-lisp::ttype) +; :calls 'nil))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasq5 LAPACK} -\pagehead{dlasq5}{dlasq5} +%\pagehead{dlasq5}{dlasq5} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -34397,27 +52496,27 @@ The result is dnm2 nil)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasq5 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (array double-float (*)) fixnum - (double-float) (double-float) (double-float) - (double-float) (double-float) (double-float) - (double-float) (member t nil)) - :return-values '(nil nil nil nil nil fortran-to-lisp::dmin - fortran-to-lisp::dmin1 fortran-to-lisp::dmin2 - fortran-to-lisp::dn fortran-to-lisp::dnm1 - fortran-to-lisp::dnm2 nil) - :calls 'nil))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasq5 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (array double-float (*)) fixnum +; (double-float) (double-float) (double-float) +; (double-float) (double-float) (double-float) +; (double-float) (member t nil)) +; :return-values '(nil nil nil nil nil fortran-to-lisp::dmin +; fortran-to-lisp::dmin1 fortran-to-lisp::dmin2 +; fortran-to-lisp::dn fortran-to-lisp::dnm1 +; fortran-to-lisp::dnm2 nil) +; :calls 'nil))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasq6 LAPACK} -\pagehead{dlasq6}{dlasq6} +%\pagehead{dlasq6}{dlasq6} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -34797,26 +52896,26 @@ The result is (return (values nil nil nil nil dmin f2cl-lib:dmin1 dmin2 dn dnm1 dnm2)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasq6 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - (array double-float (*)) fixnum - (double-float) (double-float) (double-float) - (double-float) (double-float) (double-float)) - :return-values '(nil nil nil nil fortran-to-lisp::dmin - fortran-to-lisp::dmin1 fortran-to-lisp::dmin2 - fortran-to-lisp::dn fortran-to-lisp::dnm1 - fortran-to-lisp::dnm2) - :calls '(fortran-to-lisp::dlamch)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasq6 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; (array double-float (*)) fixnum +; (double-float) (double-float) (double-float) +; (double-float) (double-float) (double-float)) +; :return-values '(nil nil nil nil fortran-to-lisp::dmin +; fortran-to-lisp::dmin1 fortran-to-lisp::dmin2 +; fortran-to-lisp::dn fortran-to-lisp::dnm1 +; fortran-to-lisp::dnm2) +; :calls '(fortran-to-lisp::dlamch)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasr LAPACK} -\pagehead{dlasr}{dlasr} +%\pagehead{dlasr}{dlasr} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -35372,24 +53471,24 @@ The result is end_label (return (values nil nil nil nil nil nil nil nil nil)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasr fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - (array double-float (*)) (array double-float (*)) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasr fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; (array double-float (*)) (array double-float (*)) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame))));;; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasrt LAPACK} -\pagehead{dlasrt}{dlasrt} +%\pagehead{dlasrt}{dlasrt} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -35608,22 +53707,22 @@ The result is end_label (return (values nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasrt - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum (array double-float (*)) - fixnum) - :return-values '(nil nil nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasrt +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlassq LAPACK} -\pagehead{dlassq}{dlassq} +%\pagehead{dlassq}{dlassq} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -35661,23 +53760,23 @@ The result is (setf sumsq (+ sumsq (expt (/ absxi scale) 2))))))))))) (return (values nil nil nil scale sumsq)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlassq - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum (array double-float (*)) - fixnum (double-float) - (double-float)) - :return-values '(nil nil nil fortran-to-lisp::scale - fortran-to-lisp::sumsq) - :calls 'nil))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlassq +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum (array double-float (*)) +; fixnum (double-float) +; (double-float)) +; :return-values '(nil nil nil fortran-to-lisp::scale +; fortran-to-lisp::sumsq) +; :calls 'nil))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasv2 LAPACK} -\pagehead{dlasv2}{dlasv2} +%\pagehead{dlasv2}{dlasv2} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -35809,25 +53908,25 @@ The result is (f2cl-lib:sign one h)))) (return (values nil nil nil ssmin ssmax snr csr snl csl))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasv2 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((double-float) (double-float) (double-float) - (double-float) (double-float) (double-float) - (double-float) (double-float) (double-float)) - :return-values '(nil nil nil fortran-to-lisp::ssmin - fortran-to-lisp::ssmax fortran-to-lisp::snr - fortran-to-lisp::csr fortran-to-lisp::snl - fortran-to-lisp::csl) - :calls '(fortran-to-lisp::dlamch)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasv2 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((double-float) (double-float) (double-float) +; (double-float) (double-float) (double-float) +; (double-float) (double-float) (double-float)) +; :return-values '(nil nil nil fortran-to-lisp::ssmin +; fortran-to-lisp::ssmax fortran-to-lisp::snr +; fortran-to-lisp::csr fortran-to-lisp::snl +; fortran-to-lisp::csl) +; :calls '(fortran-to-lisp::dlamch))));; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlaswp LAPACK} -\pagehead{dlaswp}{dlaswp} +%\pagehead{dlaswp}{dlaswp} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -35932,24 +54031,24 @@ The result is end_label (return (values nil nil nil nil nil nil nil))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlaswp - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum (array double-float (*)) - fixnum fixnum - fixnum - (array fixnum (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil) - :calls 'nil))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlaswp +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum (array double-float (*)) +; fixnum fixnum +; fixnum +; (array fixnum (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil) +; :calls 'nil)));;; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dlasy2 LAPACK} -\pagehead{dlasy2}{dlasy2} +%\pagehead{dlasy2}{dlasy2} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -36639,92 +54738,30 @@ The result is xnorm info))))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dlasy2 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((member t nil) (member t nil) - fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum (double-float) - (array double-float (*)) fixnum - (double-float) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::scale nil nil - fortran-to-lisp::xnorm fortran-to-lisp::info) - :calls '(fortran-to-lisp::dswap fortran-to-lisp::dcopy - fortran-to-lisp::idamax fortran-to-lisp::dlamch)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dnrm2 BLAS} -\pagehead{dnrm2}{dnrm2} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one 1.0) (zero 0.0)) - (declare (type (double-float 1.0 1.0) one) - (type (double-float 0.0 0.0) zero)) - (defun dnrm2 (n x incx) - (declare (type (array double-float (*)) x) - (type fixnum incx n)) - (f2cl-lib:with-multi-array-data - ((x double-float x-%data% x-%offset%)) - (prog ((absxi 0.0) (norm 0.0) (scale 0.0) (ssq 0.0) (ix 0) (dnrm2 0.0)) - (declare (type fixnum ix) - (type (double-float) absxi norm scale ssq dnrm2)) - (cond - ((or (< n 1) (< incx 1)) - (setf norm zero)) - ((= n 1) - (setf norm (abs (f2cl-lib:fref x-%data% (1) ((1 *)) x-%offset%)))) - (t - (setf scale zero) - (setf ssq one) - (f2cl-lib:fdo (ix 1 (f2cl-lib:int-add ix incx)) - ((> ix - (f2cl-lib:int-add 1 - (f2cl-lib:int-mul - (f2cl-lib:int-add n - (f2cl-lib:int-sub - 1)) - incx))) - nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (ix) ((1 *))) zero) - (setf absxi - (abs - (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%))) - (cond - ((< scale absxi) - (setf ssq (+ one (* ssq (expt (/ scale absxi) 2)))) - (setf scale absxi)) - (t - (setf ssq (+ ssq (expt (/ absxi scale) 2))))))))) - (setf norm (* scale (f2cl-lib:fsqrt ssq))))) - (setf dnrm2 norm) - end_label - (return (values dnrm2 nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dnrm2 fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum (array double-float (*)) - fixnum) - :return-values '(nil nil nil) - :calls 'nil))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dlasy2 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((member t nil) (member t nil) +; fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (double-float) +; (array double-float (*)) fixnum +; (double-float) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::scale nil nil +; fortran-to-lisp::xnorm fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dswap fortran-to-lisp::dcopy +; fortran-to-lisp::idamax fortran-to-lisp::dlamch)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dorg2r LAPACK} -\pagehead{dorg2r}{dorg2r} +%\pagehead{dorg2r}{dorg2r} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -36800,24 +54837,24 @@ The result is end_label (return (values nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dorg2r - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dscal fortran-to-lisp::dlarf - fortran-to-lisp::xerbla)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dorg2r +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dscal fortran-to-lisp::dlarf +; fortran-to-lisp::xerbla))));;; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dorgbr LAPACK} -\pagehead{dorgbr}{dorgbr} +%\pagehead{dorgbr}{dorgbr} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -37005,28 +55042,28 @@ p (cond end_label (return (values nil nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dorgbr - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dorglq fortran-to-lisp::dorgqr - fortran-to-lisp::xerbla fortran-to-lisp::ilaenv - fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dorgbr +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dorglq fortran-to-lisp::dorgqr +; fortran-to-lisp::xerbla fortran-to-lisp::ilaenv +; fortran-to-lisp::lsame)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dorghr LAPACK} -\pagehead{dorghr}{dorghr} +%\pagehead{dorghr}{dorghr} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -37143,26 +55180,26 @@ p (cond end_label (return (values nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dorghr - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dorgqr fortran-to-lisp::xerbla - fortran-to-lisp::ilaenv)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dorghr +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dorgqr fortran-to-lisp::xerbla +; fortran-to-lisp::ilaenv)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dorgl2 LAPACK} -\pagehead{dorgl2}{dorgl2} +%\pagehead{dorgl2}{dorgl2} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -37251,24 +55288,24 @@ p (cond end_label (return (values nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dorgl2 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dscal fortran-to-lisp::dlarf - fortran-to-lisp::xerbla)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dorgl2 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dscal fortran-to-lisp::dlarf +; fortran-to-lisp::xerbla))));;; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dorglq LAPACK} -\pagehead{dorglq}{dorglq} +%\pagehead{dorglq}{dorglq} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -37429,27 +55466,27 @@ p (cond end_label (return (values nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dorglq - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlarfb fortran-to-lisp::dlarft - fortran-to-lisp::dorgl2 fortran-to-lisp::xerbla - fortran-to-lisp::ilaenv)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dorglq +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlarfb fortran-to-lisp::dlarft +; fortran-to-lisp::dorgl2 fortran-to-lisp::xerbla +; fortran-to-lisp::ilaenv)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dorgqr LAPACK} -\pagehead{dorgqr}{dorgqr} +%\pagehead{dorgqr}{dorgqr} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -37609,27 +55646,27 @@ p (cond end_label (return (values nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dorgqr - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlarfb fortran-to-lisp::dlarft - fortran-to-lisp::dorg2r fortran-to-lisp::xerbla - fortran-to-lisp::ilaenv)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dorgqr +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlarfb fortran-to-lisp::dlarft +; fortran-to-lisp::dorg2r fortran-to-lisp::xerbla +; fortran-to-lisp::ilaenv)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dorm2r LAPACK} -\pagehead{dorm2r}{dorm2r} +%\pagehead{dorm2r}{dorm2r} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -37719,28 +55756,28 @@ p (cond end_label (return (values nil nil nil nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dorm2r - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlarf fortran-to-lisp::xerbla - fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dorm2r +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlarf fortran-to-lisp::xerbla +; fortran-to-lisp::lsame)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dormbr LAPACK} -\pagehead{dormbr}{dormbr} +%\pagehead{dormbr}{dormbr} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -37922,31 +55959,31 @@ p (cond (return (values nil nil nil nil nil nil nil nil nil nil nil nil nil info))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dormbr - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum - (array double-float (*)) fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dormlq fortran-to-lisp::dormqr - fortran-to-lisp::xerbla fortran-to-lisp::ilaenv - fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dormbr +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dormlq fortran-to-lisp::dormqr +; fortran-to-lisp::xerbla fortran-to-lisp::ilaenv +; fortran-to-lisp::lsame)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dorml2 LAPACK} -\pagehead{dorml2}{dorml2} +%\pagehead{dorml2}{dorml2} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -38036,28 +56073,28 @@ p (cond end_label (return (values nil nil nil nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dorml2 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlarf fortran-to-lisp::xerbla - fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dorml2 +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlarf fortran-to-lisp::xerbla +; fortran-to-lisp::lsame)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dormlq LAPACK} -\pagehead{dormlq}{dormlq} +%\pagehead{dormlq}{dormlq} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -38220,30 +56257,30 @@ p (cond (return (values nil nil nil nil nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dormlq - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum - (array double-float (*)) fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlarfb fortran-to-lisp::dlarft - fortran-to-lisp::dorml2 fortran-to-lisp::xerbla - fortran-to-lisp::ilaenv fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dormlq +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlarfb fortran-to-lisp::dlarft +; fortran-to-lisp::dorml2 fortran-to-lisp::xerbla +; fortran-to-lisp::ilaenv fortran-to-lisp::lsame)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dormqr LAPACK} -\pagehead{dormqr}{dormqr} +%\pagehead{dormqr}{dormqr} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -38398,5223 +56435,30 @@ p (cond (return (values nil nil nil nil nil nil nil nil nil nil nil nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dormqr - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum - (array double-float (*)) fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlarfb fortran-to-lisp::dlarft - fortran-to-lisp::dorm2r fortran-to-lisp::xerbla - fortran-to-lisp::ilaenv fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{drotg BLAS} -\pagehead{drotg}{drotg} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -Double precision. Computes plane rotation. -Arguments are: -\begin{itemize} -\item da - double-float -\item db - double-float -\item c - double-float -\item s - double-float -\end{itemize} -Returns multiple values where: -\begin{itemize} -\item 1 da - double-float -\item 2 db - double-float -\item 3 c - double-float -\item 4 s - double-float -\end{itemize} - -<>= -(defun drotg (da db c s) - (declare (type (double-float) s c db da)) - (prog ((roe 0.0) (scale 0.0) (r 0.0) (z 0.0)) - (declare (type (double-float) z r scale roe)) - (setf roe db) - (when (> (the double-float (abs da)) (the double-float (abs db))) - (setf roe da)) - (setf scale (+ (the double-float (abs da)) (the double-float (abs db)))) - (if (/= scale 0.0) (go label10)) - (setf c 1.0) - (setf s 0.0) - (setf r 0.0) - (setf z 0.0) - (go label20) - label10 - (setf r - (* scale (f2cl-lib:dsqrt (+ (expt (/ da scale) 2) (expt (/ db scale) 2))))) - (setf r (* (f2cl-lib:dsign 1.0 roe) r)) - (setf c (/ da r)) - (setf s (/ db r)) - (setf z 1.0) - (when (> (the double-float (abs da)) (the double-float (abs db))) - (setf z s)) - (if (and (>= (the double-float (abs db)) (the double-float (abs da))) - (/= c 0.0)) - (setf z (/ 1.0 c))) - label20 - (setf da r) - (setf db z) - (return (values da db c s)))) - ;(in-package #-gcl #:cl-user #+gcl "CL-USER") ;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) ;(eval-when (:load-toplevel :compile-toplevel :execute) -; (setf (gethash 'fortran-to-lisp::drotg fortran-to-lisp::*f2cl-function-info*) +; (setf (gethash 'fortran-to-lisp::dormqr +; fortran-to-lisp::*f2cl-function-info*) ; (fortran-to-lisp::make-f2cl-finfo -; :arg-types '((double-float) (double-float) (double-float) -; (double-float)) -; :return-values '(fortran-to-lisp::da fortran-to-lisp::db -; fortran-to-lisp::c fortran-to-lisp::s) -; :calls 'nil))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{drot BLAS} -\pagehead{drot}{drot} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(defun drot (n dx incx dy incy c s) - (declare (type (double-float) s c) - (type (array double-float (*)) dy dx) - (type fixnum incy incx n)) - (f2cl-lib:with-multi-array-data - ((dx double-float dx-%data% dx-%offset%) - (dy double-float dy-%data% dy-%offset%)) - (prog ((i 0) (ix 0) (iy 0) (dtemp 0.0)) - (declare (type (double-float) dtemp) (type fixnum iy ix i)) - (if (<= n 0) (go end_label)) - (if (and (= incx 1) (= incy 1)) (go label20)) - (setf ix 1) - (setf iy 1) - (if (< incx 0) - (setf ix - (f2cl-lib:int-add - (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) - 1))) - (if (< incy 0) - (setf iy - (f2cl-lib:int-add - (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) - 1))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf dtemp - (+ (* c (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%)) - (* s (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%)))) - (setf (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%) - (- (* c (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%)) - (* s (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%)))) - (setf (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%) dtemp) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))) - (go end_label) - label20 - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf dtemp - (+ (* c (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)) - (* s (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%)))) - (setf (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%) - (- (* c (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%)) - (* s (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)))) - (setf (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) dtemp))) - end_label - (return (values nil nil nil nil nil nil nil))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::drot fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum (double-float) - (double-float)) - :return-values '(nil nil nil nil nil nil nil) - :calls 'nil))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dsbmv BLAS} -\pagehead{dsbmv}{dsbmv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one 1.0) (zero 0.0)) - (declare (type (double-float 1.0 1.0) one) - (type (double-float 0.0 0.0) zero)) - (defun dsbmv (uplo n k alpha a lda x incx beta y incy) - (declare (type (array double-float (*)) y x a) - (type (double-float) beta alpha) - (type fixnum incy incx lda k n) - (type (simple-array character (*)) uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (a double-float a-%data% a-%offset%) - (x double-float x-%data% x-%offset%) - (y double-float y-%data% y-%offset%)) - (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (kplus1 0) (kx 0) - (ky 0) (l 0) (temp1 0.0) (temp2 0.0)) - (declare (type fixnum i info ix iy j jx jy kplus1 kx ky l) - (type (double-float) temp1 temp2)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((< n 0) - (setf info 2)) - ((< k 0) - (setf info 3)) - ((< lda (f2cl-lib:int-add k 1)) - (setf info 6)) - ((= incx 0) - (setf info 8)) - ((= incy 0) - (setf info 11))) - (cond - ((/= info 0) - (xerbla "DSBMV " info) - (go end_label))) - (if (or (= n 0) (and (= alpha zero) (= beta one))) (go end_label)) - (cond - ((> incx 0) - (setf kx 1)) - (t - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx))))) - (cond - ((> incy 0) - (setf ky 1)) - (t - (setf ky - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incy))))) - (cond - ((/= beta one) - (cond - ((= incy 1) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - zero)))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%)))))))) - (t - (setf iy ky) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - zero) - (setf iy (f2cl-lib:int-add iy incy))))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%))) - (setf iy (f2cl-lib:int-add iy incy)))))))))) - (if (= alpha zero) (go end_label)) - (cond - ((lsame uplo "U") - (setf kplus1 (f2cl-lib:int-add k 1)) - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf l (f2cl-lib:int-sub kplus1 j)) - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k)))) - (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%)) - (* alpha temp2)))))) - (t - (setf jx kx) - (setf jy ky) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf ix kx) - (setf iy ky) - (setf l (f2cl-lib:int-sub kplus1 j)) - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k)))) - (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%)) - (* alpha temp2))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy)) - (cond - ((> j k) - (setf kx (f2cl-lib:int-add kx incx)) - (setf ky (f2cl-lib:int-add ky incy))))))))) - (t - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf l (f2cl-lib:int-sub 1 j)) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k)))) - nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (* alpha temp2)))))) - (t - (setf jx kx) - (setf jy ky) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf l (f2cl-lib:int-sub 1 j)) - (setf ix jx) - (setf iy jy) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k)))) - nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)) - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* alpha temp2))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy)))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dsbmv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum fixnum - (double-float) (array double-float (*)) - fixnum (array double-float (*)) - fixnum (double-float) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dscal BLAS} -\pagehead{dscal}{dscal} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(defun dscal (n da dx incx) - (declare (type (array double-float (*)) dx) - (type (double-float) da) - (type fixnum incx n)) - (f2cl-lib:with-multi-array-data - ((dx double-float dx-%data% dx-%offset%)) - (prog ((i 0) (m 0) (mp1 0) (nincx 0)) - (declare (type fixnum nincx mp1 m i)) - (if (or (<= n 0) (<= incx 0)) (go end_label)) - (if (= incx 1) (go label20)) - (setf nincx (f2cl-lib:int-mul n incx)) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i incx)) - ((> i nincx) nil) - (tagbody - (setf (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) - (* da (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%))))) - (go end_label) - label20 - (setf m (mod n 5)) - (if (= m 0) (go label40)) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) - (* da (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%))))) - (if (< n 5) (go end_label)) - label40 - (setf mp1 (f2cl-lib:int-add m 1)) - (f2cl-lib:fdo (i mp1 (f2cl-lib:int-add i 5)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) - (* da (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%))) - (setf (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 1)) - ((1 *)) - dx-%offset%) - (* da - (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 1)) - ((1 *)) - dx-%offset%))) - (setf (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 2)) - ((1 *)) - dx-%offset%) - (* da - (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 2)) - ((1 *)) - dx-%offset%))) - (setf (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 3)) - ((1 *)) - dx-%offset%) - (* da - (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 3)) - ((1 *)) - dx-%offset%))) - (setf (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 4)) - ((1 *)) - dx-%offset%) - (* da - (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 4)) - ((1 *)) - dx-%offset%))))) - end_label - (return (values nil nil nil nil))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dscal fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum (double-float) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil) - :calls 'nil))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dspmv BLAS} -\pagehead{dspmv}{dspmv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one 1.0) (zero 0.0)) - (declare (type (double-float 1.0 1.0) one) - (type (double-float 0.0 0.0) zero)) - (defun dspmv (uplo n alpha ap x incx beta y incy) - (declare (type (array double-float (*)) y x ap) - (type (double-float) beta alpha) - (type fixnum incy incx n) - (type (simple-array character (*)) uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (ap double-float ap-%data% ap-%offset%) - (x double-float x-%data% x-%offset%) - (y double-float y-%data% y-%offset%)) - (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (k 0) (kk 0) - (kx 0) (ky 0) (temp1 0.0) (temp2 0.0)) - (declare (type fixnum i info ix iy j jx jy k kk kx ky) - (type (double-float) temp1 temp2)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((< n 0) - (setf info 2)) - ((= incx 0) - (setf info 6)) - ((= incy 0) - (setf info 9))) - (cond - ((/= info 0) - (xerbla "DSPMV " info) - (go end_label))) - (if (or (= n 0) (and (= alpha zero) (= beta one))) (go end_label)) - (cond - ((> incx 0) - (setf kx 1)) - (t - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx))))) - (cond - ((> incy 0) - (setf ky 1)) - (t - (setf ky - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incy))))) - (cond - ((/= beta one) - (cond - ((= incy 1) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - zero)))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%)))))))) - (t - (setf iy ky) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - zero) - (setf iy (f2cl-lib:int-add iy incy))))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%))) - (setf iy (f2cl-lib:int-add iy incy)))))))))) - (if (= alpha zero) (go end_label)) - (setf kk 1) - (cond - ((lsame uplo "U") - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf k kk) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))) - (setf k (f2cl-lib:int-add k 1)))) - (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%)) - (* alpha temp2))) - (setf kk (f2cl-lib:int-add kk j))))) - (t - (setf jx kx) - (setf jy ky) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf ix kx) - (setf iy ky) - (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - j - (f2cl-lib:int-sub 2))) - nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%)) - (* alpha temp2))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy)) - (setf kk (f2cl-lib:int-add kk j))))))) - (t - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)))) - (setf k (f2cl-lib:int-add kk 1)) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))) - (setf k (f2cl-lib:int-add k 1)))) - (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (* alpha temp2))) - (setf kk - (f2cl-lib:int-add kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1)))))) - (t - (setf jx kx) - (setf jy ky) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)))) - (setf ix jx) - (setf iy jy) - (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) - (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - n - (f2cl-lib:int-sub j))) - nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)) - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* alpha temp2))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy)) - (setf kk - (f2cl-lib:int-add kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dspmv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum (double-float) - (array double-float (*)) (array double-float (*)) - fixnum (double-float) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dspr2 BLAS} -\pagehead{dspr2}{dspr2} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero 0.0)) - (declare (type (double-float 0.0 0.0) zero)) - (defun dspr2 (uplo n alpha x incx y incy ap) - (declare (type (array double-float (*)) ap y x) - (type (double-float) alpha) - (type fixnum incy incx n) - (type (simple-array character (*)) uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (x double-float x-%data% x-%offset%) - (y double-float y-%data% y-%offset%) - (ap double-float ap-%data% ap-%offset%)) - (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (k 0) (kk 0) - (kx 0) (ky 0) (temp1 0.0) (temp2 0.0)) - (declare (type fixnum i info ix iy j jx jy k kk kx ky) - (type (double-float) temp1 temp2)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((< n 0) - (setf info 2)) - ((= incx 0) - (setf info 5)) - ((= incy 0) - (setf info 7))) - (cond - ((/= info 0) - (xerbla "DSPR2 " info) - (go end_label))) - (if (or (= n 0) (= alpha zero)) (go end_label)) - (cond - ((or (/= incx 1) (/= incy 1)) - (cond - ((> incx 0) - (setf kx 1)) - (t - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))))) - (cond - ((> incy 0) - (setf ky 1)) - (t - (setf ky - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incy))))) - (setf jx kx) - (setf jy ky))) - (setf kk 1) - (cond - ((lsame uplo "U") - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) - (/= (f2cl-lib:fref y (j) ((1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:fref y-%data% - (j) - ((1 *)) - y-%offset%))) - (setf temp2 - (* alpha - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%))) - (setf k kk) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (+ - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (* - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%) - temp2))) - (setf k (f2cl-lib:int-add k 1)))))) - (setf kk (f2cl-lib:int-add kk j))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:fref y-%data% - (jy) - ((1 *)) - y-%offset%))) - (setf temp2 - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - (setf ix kx) - (setf iy ky) - (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (+ - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (* - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%) - temp2))) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy)) - (setf kk (f2cl-lib:int-add kk j))))))) - (t - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) - (/= (f2cl-lib:fref y (j) ((1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:fref y-%data% - (j) - ((1 *)) - y-%offset%))) - (setf temp2 - (* alpha - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%))) - (setf k kk) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (+ - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (* - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%) - temp2))) - (setf k (f2cl-lib:int-add k 1)))))) - (setf kk - (f2cl-lib:int-add - (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) - 1))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:fref y-%data% - (jy) - ((1 *)) - y-%offset%))) - (setf temp2 - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - (setf ix jx) - (setf iy jy) - (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - n - (f2cl-lib:int-sub j))) - nil) - (tagbody - (setf (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (+ - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (* - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%) - temp2))) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy)) - (setf kk - (f2cl-lib:int-add - (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) - 1)))))))) - end_label - (return (values nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dspr2 fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum (double-float) - (array double-float (*)) fixnum - (array double-float (*)) fixnum - (array double-float (*))) - :return-values '(nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dspr BLAS} -\pagehead{dspr}{dspr} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero 0.0)) - (declare (type (double-float 0.0 0.0) zero)) - (defun dspr (uplo n alpha x incx ap) - (declare (type (array double-float (*)) ap x) - (type (double-float) alpha) - (type fixnum incx n) - (type (simple-array character (*)) uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (x double-float x-%data% x-%offset%) - (ap double-float ap-%data% ap-%offset%)) - (prog ((i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0) (kk 0) (kx 0) (temp 0.0)) - (declare (type fixnum i info ix j jx k kk kx) - (type (double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((< n 0) - (setf info 2)) - ((= incx 0) - (setf info 5))) - (cond - ((/= info 0) - (xerbla "DSPR " info) - (go end_label))) - (if (or (= n 0) (= alpha zero)) (go end_label)) - (cond - ((<= incx 0) - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx)))) - ((/= incx 1) - (setf kx 1))) - (setf kk 1) - (cond - ((lsame uplo "U") - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%))) - (setf k kk) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (+ - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (* - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - temp))) - (setf k (f2cl-lib:int-add k 1)))))) - (setf kk (f2cl-lib:int-add kk j))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - (setf ix kx) - (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (+ - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (* - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - temp))) - (setf ix (f2cl-lib:int-add ix incx)))))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf kk (f2cl-lib:int-add kk j))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%))) - (setf k kk) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (+ - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (* - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - temp))) - (setf k (f2cl-lib:int-add k 1)))))) - (setf kk - (f2cl-lib:int-add - (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) - 1))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - (setf ix jx) - (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - n - (f2cl-lib:int-sub j))) - nil) - (tagbody - (setf (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (+ - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (* - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - temp))) - (setf ix (f2cl-lib:int-add ix incx)))))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf kk - (f2cl-lib:int-add - (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) - 1)))))))) - end_label - (return (values nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dspr fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum (double-float) - (array double-float (*)) fixnum - (array double-float (*))) - :return-values '(nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dswap BLAS} -\pagehead{dswap}{dswap} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(defun dswap (n dx incx dy incy) - (declare (type (array double-float (*)) dy dx) - (type fixnum incy incx n)) - (f2cl-lib:with-multi-array-data - ((dx double-float dx-%data% dx-%offset%) - (dy double-float dy-%data% dy-%offset%)) - (prog ((i 0) (ix 0) (iy 0) (m 0) (mp1 0) (dtemp 0.0)) - (declare (type (double-float) dtemp) - (type fixnum mp1 m iy ix i)) - (if (<= n 0) (go end_label)) - (if (and (= incx 1) (= incy 1)) (go label20)) - (setf ix 1) - (setf iy 1) - (if (< incx 0) - (setf ix - (f2cl-lib:int-add - (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) - 1))) - (if (< incy 0) - (setf iy - (f2cl-lib:int-add - (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) - 1))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf dtemp (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%)) - (setf (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%) - (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%)) - (setf (f2cl-lib:fref dy-%data% (iy) ((1 *)) dy-%offset%) dtemp) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))) - (go end_label) - label20 - (setf m (mod n 3)) - (if (= m 0) (go label40)) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf dtemp (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)) - (setf (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) - (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%)) - (setf (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%) dtemp))) - (if (< n 3) (go end_label)) - label40 - (setf mp1 (f2cl-lib:int-add m 1)) - (f2cl-lib:fdo (i mp1 (f2cl-lib:int-add i 3)) - ((> i n) nil) - (tagbody - (setf dtemp (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)) - (setf (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%) - (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%)) - (setf (f2cl-lib:fref dy-%data% (i) ((1 *)) dy-%offset%) dtemp) - (setf dtemp - (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 1)) - ((1 *)) - dx-%offset%)) - (setf (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 1)) - ((1 *)) - dx-%offset%) - (f2cl-lib:fref dy-%data% - ((f2cl-lib:int-add i 1)) - ((1 *)) - dy-%offset%)) - (setf (f2cl-lib:fref dy-%data% - ((f2cl-lib:int-add i 1)) - ((1 *)) - dy-%offset%) - dtemp) - (setf dtemp - (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 2)) - ((1 *)) - dx-%offset%)) - (setf (f2cl-lib:fref dx-%data% - ((f2cl-lib:int-add i 2)) - ((1 *)) - dx-%offset%) - (f2cl-lib:fref dy-%data% - ((f2cl-lib:int-add i 2)) - ((1 *)) - dy-%offset%)) - (setf (f2cl-lib:fref dy-%data% - ((f2cl-lib:int-add i 2)) - ((1 *)) - dy-%offset%) - dtemp))) - end_label - (return (values nil nil nil nil nil))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dswap fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil) - :calls 'nil))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dsymm BLAS} -\pagehead{dsymm}{dsymm} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one 1.0) (zero 0.0)) - (declare (type (double-float 1.0 1.0) one) - (type (double-float 0.0 0.0) zero)) - (defun dsymm (side uplo m n alpha a lda b ldb$ beta c ldc) - (declare (type (array double-float (*)) c b a) - (type (double-float) beta alpha) - (type fixnum ldc ldb$ lda n m) - (type (simple-array character (*)) uplo side)) - (f2cl-lib:with-multi-array-data - ((side character side-%data% side-%offset%) - (uplo character uplo-%data% uplo-%offset%) - (a double-float a-%data% a-%offset%) - (b double-float b-%data% b-%offset%) - (c double-float c-%data% c-%offset%)) - (prog ((temp1 0.0) (temp2 0.0) (i 0) (info 0) (j 0) (k 0) (nrowa 0) - (upper nil)) - (declare (type (double-float) temp1 temp2) - (type fixnum i info j k nrowa) - (type (member t nil) upper)) - (cond - ((lsame side "L") - (setf nrowa m)) - (t - (setf nrowa n))) - (setf upper (lsame uplo "U")) - (setf info 0) - (cond - ((and (not (lsame side "L")) (not (lsame side "R"))) - (setf info 1)) - ((and (not upper) (not (lsame uplo "L"))) - (setf info 2)) - ((< m 0) - (setf info 3)) - ((< n 0) - (setf info 4)) - ((< lda (max (the fixnum 1) (the fixnum nrowa))) - (setf info 7)) - ((< ldb$ (max (the fixnum 1) (the fixnum m))) - (setf info 9)) - ((< ldc (max (the fixnum 1) (the fixnum m))) - (setf info 12))) - (cond - ((/= info 0) - (xerbla "DSYMM " info) - (go end_label))) - (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one))) - (go end_label)) - (cond - ((= alpha zero) - (cond - ((= beta zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))))) - (go end_label))) - (cond - ((lsame side "L") - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))) - (setf temp2 zero) - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add i - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (k j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (k j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* temp1 - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%)) - (* alpha temp2)))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)) - (* temp1 - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%)) - (* alpha temp2)))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i m (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))) - (setf temp2 zero) - (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) - (f2cl-lib:int-add k 1)) - ((> k m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (k j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (k j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* temp1 - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%)) - (* alpha temp2)))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)) - (* temp1 - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%)) - (* alpha temp2)))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp1 - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%)))))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)) - (* temp1 - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%)))))))) - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - nil) - (tagbody - (cond - (upper - (setf temp1 - (* alpha - (f2cl-lib:fref a-%data% - (k j) - ((1 lda) (1 *)) - a-%offset%)))) - (t - (setf temp1 - (* alpha - (f2cl-lib:fref a-%data% - (j k) - ((1 lda) (1 *)) - a-%offset%))))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp1 - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))) - (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) (f2cl-lib:int-add k 1)) - ((> k n) nil) - (tagbody - (cond - (upper - (setf temp1 - (* alpha - (f2cl-lib:fref a-%data% - (j k) - ((1 lda) (1 *)) - a-%offset%)))) - (t - (setf temp1 - (* alpha - (f2cl-lib:fref a-%data% - (k j) - ((1 lda) (1 *)) - a-%offset%))))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp1 - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dsymm fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - (double-float) (array double-float (*)) - fixnum (array double-float (*)) - fixnum (double-float) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dsymv BLAS} -\pagehead{dsymv}{dsymv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one 1.0) (zero 0.0)) - (declare (type (double-float 1.0 1.0) one) - (type (double-float 0.0 0.0) zero)) - (defun dsymv (uplo n alpha a lda x incx beta y incy) - (declare (type (array double-float (*)) y x a) - (type (double-float) beta alpha) - (type fixnum incy incx lda n) - (type (simple-array character (*)) uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (a double-float a-%data% a-%offset%) - (x double-float x-%data% x-%offset%) - (y double-float y-%data% y-%offset%)) - (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (kx 0) (ky 0) - (temp1 0.0) (temp2 0.0)) - (declare (type fixnum i info ix iy j jx jy kx ky) - (type (double-float) temp1 temp2)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((< n 0) - (setf info 2)) - ((< lda (max (the fixnum 1) (the fixnum n))) - (setf info 5)) - ((= incx 0) - (setf info 7)) - ((= incy 0) - (setf info 10))) - (cond - ((/= info 0) - (xerbla "DSYMV " info) - (go end_label))) - (if (or (= n 0) (and (= alpha zero) (= beta one))) (go end_label)) - (cond - ((> incx 0) - (setf kx 1)) - (t - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx))))) - (cond - ((> incy 0) - (setf ky 1)) - (t - (setf ky - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incy))))) - (cond - ((/= beta one) - (cond - ((= incy 1) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - zero)))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%)))))))) - (t - (setf iy ky) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - zero) - (setf iy (f2cl-lib:int-add iy incy))))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%))) - (setf iy (f2cl-lib:int-add iy incy)))))))))) - (if (= alpha zero) (go end_label)) - (cond - ((lsame uplo "U") - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) - (setf temp2 zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) - (* alpha temp2)))))) - (t - (setf jx kx) - (setf jy ky) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf ix kx) - (setf iy ky) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) - (* alpha temp2))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy))))))) - (t - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (* alpha temp2)))))) - (t - (setf jx kx) - (setf jy ky) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf ix jx) - (setf iy jy) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)) - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* alpha temp2))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy)))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dsymv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum (double-float) - (array double-float (*)) fixnum - (array double-float (*)) fixnum - (double-float) (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dsyr2k BLAS} -\pagehead{dsyr2k}{dsyr2k} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one 1.0) (zero 0.0)) - (declare (type (double-float 1.0 1.0) one) - (type (double-float 0.0 0.0) zero)) - (defun dsyr2k (uplo trans n k alpha a lda b ldb$ beta c ldc) - (declare (type (array double-float (*)) c b a) - (type (double-float) beta alpha) - (type fixnum ldc ldb$ lda k n) - (type (simple-array character (*)) trans uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (trans character trans-%data% trans-%offset%) - (a double-float a-%data% a-%offset%) - (b double-float b-%data% b-%offset%) - (c double-float c-%data% c-%offset%)) - (prog ((temp1 0.0) (temp2 0.0) (i 0) (info 0) (j 0) (l 0) (nrowa 0) - (upper nil)) - (declare (type (double-float) temp1 temp2) - (type fixnum i info j l nrowa) - (type (member t nil) upper)) - (cond - ((lsame trans "N") - (setf nrowa n)) - (t - (setf nrowa k))) - (setf upper (lsame uplo "U")) - (setf info 0) - (cond - ((and (not upper) (not (lsame uplo "L"))) - (setf info 1)) - ((and (not (lsame trans "N")) - (not (lsame trans "T")) - (not (lsame trans "C"))) - (setf info 2)) - ((< n 0) - (setf info 3)) - ((< k 0) - (setf info 4)) - ((< lda (max (the fixnum 1) (the fixnum nrowa))) - (setf info 7)) - ((< ldb$ - (max (the fixnum 1) (the fixnum nrowa))) - (setf info 9)) - ((< ldc (max (the fixnum 1) (the fixnum n))) - (setf info 12))) - (cond - ((/= info 0) - (xerbla "DSYR2K" info) - (go end_label))) - (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) - (go end_label)) - (cond - ((= alpha zero) - (cond - (upper - (cond - ((= beta zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)))))))))) - (t - (cond - ((= beta zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))))))) - (go end_label))) - (cond - ((lsame trans "N") - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))) - ((/= beta one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) - (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:fref b-%data% - (j l) - ((1 ldb$) (1 *)) - b-%offset%))) - (setf temp2 - (* alpha - (f2cl-lib:fref a-%data% - (j l) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* - (f2cl-lib:fref a-%data% - (i l) - ((1 lda) (1 *)) - a-%offset%) - temp1) - (* - (f2cl-lib:fref b-%data% - (i l) - ((1 ldb$) (1 *)) - b-%offset%) - temp2)))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((= beta zero) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))) - ((/= beta one) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) - (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:fref b-%data% - (j l) - ((1 ldb$) (1 *)) - b-%offset%))) - (setf temp2 - (* alpha - (f2cl-lib:fref a-%data% - (j l) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* - (f2cl-lib:fref a-%data% - (i l) - ((1 lda) (1 *)) - a-%offset%) - temp1) - (* - (f2cl-lib:fref b-%data% - (i l) - ((1 ldb$) (1 *)) - b-%offset%) - temp2)))))))))))))) - (t - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf temp1 zero) - (setf temp2 zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp1 - (+ temp1 - (* - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (l j) - ((1 ldb$) (1 *)) - b-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref b-%data% - (l i) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:fref a-%data% - (l j) - ((1 lda) (1 *)) - a-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp1) (* alpha temp2)))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)) - (* alpha temp1) - (* alpha temp2)))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf temp1 zero) - (setf temp2 zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp1 - (+ temp1 - (* - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (l j) - ((1 ldb$) (1 *)) - b-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref b-%data% - (l i) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:fref a-%data% - (l j) - ((1 lda) (1 *)) - a-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp1) (* alpha temp2)))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)) - (* alpha temp1) - (* alpha temp2))))))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dsyr2k - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - (double-float) (array double-float (*)) - fixnum (array double-float (*)) - fixnum (double-float) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dsyr2 BLAS} -\pagehead{dsyr2}{dsyr2} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero 0.0)) - (declare (type (double-float 0.0 0.0) zero)) - (defun dsyr2 (uplo n alpha x incx y incy a lda) - (declare (type (array double-float (*)) a y x) - (type (double-float) alpha) - (type fixnum lda incy incx n) - (type (simple-array character (*)) uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (x double-float x-%data% x-%offset%) - (y double-float y-%data% y-%offset%) - (a double-float a-%data% a-%offset%)) - (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (kx 0) (ky 0) - (temp1 0.0) (temp2 0.0)) - (declare (type fixnum i info ix iy j jx jy kx ky) - (type (double-float) temp1 temp2)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((< n 0) - (setf info 2)) - ((= incx 0) - (setf info 5)) - ((= incy 0) - (setf info 7)) - ((< lda (max (the fixnum 1) (the fixnum n))) - (setf info 9))) - (cond - ((/= info 0) - (xerbla "DSYR2 " info) - (go end_label))) - (if (or (= n 0) (= alpha zero)) (go end_label)) - (cond - ((or (/= incx 1) (/= incy 1)) - (cond - ((> incx 0) - (setf kx 1)) - (t - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))))) - (cond - ((> incy 0) - (setf ky 1)) - (t - (setf ky - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incy))))) - (setf jx kx) - (setf jy ky))) - (cond - ((lsame uplo "U") - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) - (/= (f2cl-lib:fref y (j) ((1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:fref y-%data% - (j) - ((1 *)) - y-%offset%))) - (setf temp2 - (* alpha - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%) - temp2)))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:fref y-%data% - (jy) - ((1 *)) - y-%offset%))) - (setf temp2 - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - (setf ix kx) - (setf iy ky) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%) - temp2))) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy))))))) - (t - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) - (/= (f2cl-lib:fref y (j) ((1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:fref y-%data% - (j) - ((1 *)) - y-%offset%))) - (setf temp2 - (* alpha - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%))) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%) - temp2)))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:fref y-%data% - (jy) - ((1 *)) - y-%offset%))) - (setf temp2 - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - (setf ix jx) - (setf iy jy) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%) - temp2))) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy)))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dsyr2 fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum (double-float) - (array double-float (*)) fixnum - (array double-float (*)) fixnum - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dsyrk BLAS} -\pagehead{dsyrk}{dsyrk} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one 1.0) (zero 0.0)) - (declare (type (double-float 1.0 1.0) one) - (type (double-float 0.0 0.0) zero)) - (defun dsyrk (uplo trans n k alpha a lda beta c ldc) - (declare (type (array double-float (*)) c a) - (type (double-float) beta alpha) - (type fixnum ldc lda k n) - (type (simple-array character (*)) trans uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (trans character trans-%data% trans-%offset%) - (a double-float a-%data% a-%offset%) - (c double-float c-%data% c-%offset%)) - (prog ((temp 0.0) (i 0) (info 0) (j 0) (l 0) (nrowa 0) (upper nil)) - (declare (type (double-float) temp) - (type fixnum i info j l nrowa) - (type (member t nil) upper)) - (cond - ((lsame trans "N") - (setf nrowa n)) - (t - (setf nrowa k))) - (setf upper (lsame uplo "U")) - (setf info 0) - (cond - ((and (not upper) (not (lsame uplo "L"))) - (setf info 1)) - ((and (not (lsame trans "N")) - (not (lsame trans "T")) - (not (lsame trans "C"))) - (setf info 2)) - ((< n 0) - (setf info 3)) - ((< k 0) - (setf info 4)) - ((< lda (max (the fixnum 1) (the fixnum nrowa))) - (setf info 7)) - ((< ldc (max (the fixnum 1) (the fixnum n))) - (setf info 10))) - (cond - ((/= info 0) - (xerbla "DSYRK " info) - (go end_label))) - (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) - (go end_label)) - (cond - ((= alpha zero) - (cond - (upper - (cond - ((= beta zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)))))))))) - (t - (cond - ((= beta zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))))))) - (go end_label))) - (cond - ((lsame trans "N") - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))) - ((/= beta one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref a-%data% - (j l) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i l) - ((1 lda) (1 *)) - a-%offset%))))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((= beta zero) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))) - ((/= beta one) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref a-%data% - (j l) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i l) - ((1 lda) (1 *)) - a-%offset%))))))))))))))) - (t - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf temp zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref a-%data% - (l j) - ((1 lda) (1 *)) - a-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* alpha temp))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf temp zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref a-%data% - (l j) - ((1 lda) (1 *)) - a-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* alpha temp))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)))))))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dsyrk fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - (double-float) (array double-float (*)) - fixnum (double-float) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dsyr BLAS} -\pagehead{dsyr}{dsyr} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero 0.0)) - (declare (type (double-float 0.0 0.0) zero)) - (defun dsyr (uplo n alpha x incx a lda) - (declare (type (array double-float (*)) a x) - (type (double-float) alpha) - (type fixnum lda incx n) - (type (simple-array character (*)) uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (x double-float x-%data% x-%offset%) - (a double-float a-%data% a-%offset%)) - (prog ((i 0) (info 0) (ix 0) (j 0) (jx 0) (kx 0) (temp 0.0)) - (declare (type fixnum i info ix j jx kx) - (type (double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((< n 0) - (setf info 2)) - ((= incx 0) - (setf info 5)) - ((< lda (max (the fixnum 1) (the fixnum n))) - (setf info 7))) - (cond - ((/= info 0) - (xerbla "DSYR " info) - (go end_label))) - (if (or (= n 0) (= alpha zero)) (go end_label)) - (cond - ((<= incx 0) - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx)))) - ((/= incx 1) - (setf kx 1))) - (cond - ((lsame uplo "U") - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - temp)))))))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - (setf ix kx) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - temp))) - (setf ix (f2cl-lib:int-add ix incx)))))) - (setf jx (f2cl-lib:int-add jx incx))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%))) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - temp)))))))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - (setf ix jx) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - temp))) - (setf ix (f2cl-lib:int-add ix incx)))))) - (setf jx (f2cl-lib:int-add jx incx)))))))) - end_label - (return (values nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dsyr fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum (double-float) - (array double-float (*)) fixnum - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dtbmv BLAS} -\pagehead{dtbmv}{dtbmv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero 0.0)) - (declare (type (double-float 0.0 0.0) zero)) - (defun dtbmv (uplo trans diag n k a lda x incx) - (declare (type (array double-float (*)) x a) - (type fixnum incx lda k n) - (type (simple-array character (*)) diag trans uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (trans character trans-%data% trans-%offset%) - (diag character diag-%data% diag-%offset%) - (a double-float a-%data% a-%offset%) - (x double-float x-%data% x-%offset%)) - (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (kplus1 0) (kx 0) - (l 0) (temp 0.0)) - (declare (type (member t nil) nounit) - (type fixnum i info ix j jx kplus1 kx l) - (type (double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((and (not (lsame trans "N")) - (not (lsame trans "T")) - (not (lsame trans "C"))) - (setf info 2)) - ((and (not (lsame diag "U")) (not (lsame diag "N"))) - (setf info 3)) - ((< n 0) - (setf info 4)) - ((< k 0) - (setf info 5)) - ((< lda (f2cl-lib:int-add k 1)) - (setf info 7)) - ((= incx 0) - (setf info 9))) - (cond - ((/= info 0) - (xerbla "DTBMV " info) - (go end_label))) - (if (= n 0) (go end_label)) - (setf nounit (lsame diag "N")) - (cond - ((<= incx 0) - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx)))) - ((/= incx 1) - (setf kx 1))) - (cond - ((lsame trans "N") - (cond - ((lsame uplo "U") - (setf kplus1 (f2cl-lib:int-add k 1)) - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf l (f2cl-lib:int-sub kplus1 j)) - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k)))) - (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)))))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%))))))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix kx) - (setf l (f2cl-lib:int-sub kplus1 j)) - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k)))) - (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%)))))) - (setf jx (f2cl-lib:int-add jx incx)) - (if (> j k) (setf kx (f2cl-lib:int-add kx incx)))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf l (f2cl-lib:int-sub 1 j)) - (f2cl-lib:fdo (i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k))) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)))))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%))))))))) - (t - (setf kx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (setf jx kx) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix kx) - (setf l (f2cl-lib:int-sub 1 j)) - (f2cl-lib:fdo (i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k))) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx)))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%)))))) - (setf jx (f2cl-lib:int-sub jx incx)) - (if (>= (f2cl-lib:int-sub n j) k) - (setf kx (f2cl-lib:int-sub kx incx)))))))))) - (t - (cond - ((lsame uplo "U") - (setf kplus1 (f2cl-lib:int-add k 1)) - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf l (f2cl-lib:int-sub kplus1 j)) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) - ((> i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k))))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp)))) - (t - (setf kx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (setf jx kx) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf kx (f2cl-lib:int-sub kx incx)) - (setf ix kx) - (setf l (f2cl-lib:int-sub kplus1 j)) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) - ((> i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k))))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx)))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-sub jx incx))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf l (f2cl-lib:int-sub 1 j)) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k)))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp)))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf kx (f2cl-lib:int-add kx incx)) - (setf ix kx) - (setf l (f2cl-lib:int-sub 1 j)) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k)))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-add jx incx)))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dtbmv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - (array double-float (*)) fixnum - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dtbsv BLAS} -\pagehead{dtbsv}{dtbsv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero 0.0)) - (declare (type (double-float 0.0 0.0) zero)) - (defun dtbsv (uplo trans diag n k a lda x incx) - (declare (type (array double-float (*)) x a) - (type fixnum incx lda k n) - (type (simple-array character (*)) diag trans uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (trans character trans-%data% trans-%offset%) - (diag character diag-%data% diag-%offset%) - (a double-float a-%data% a-%offset%) - (x double-float x-%data% x-%offset%)) - (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (kplus1 0) (kx 0) - (l 0) (temp 0.0)) - (declare (type (member t nil) nounit) - (type fixnum i info ix j jx kplus1 kx l) - (type (double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((and (not (lsame trans "N")) - (not (lsame trans "T")) - (not (lsame trans "C"))) - (setf info 2)) - ((and (not (lsame diag "U")) (not (lsame diag "N"))) - (setf info 3)) - ((< n 0) - (setf info 4)) - ((< k 0) - (setf info 5)) - ((< lda (f2cl-lib:int-add k 1)) - (setf info 7)) - ((= incx 0) - (setf info 9))) - (cond - ((/= info 0) - (xerbla "DTBSV " info) - (go end_label))) - (if (= n 0) (go end_label)) - (setf nounit (lsame diag "N")) - (cond - ((<= incx 0) - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx)))) - ((/= incx 1) - (setf kx 1))) - (cond - ((lsame trans "N") - (cond - ((lsame uplo "U") - (setf kplus1 (f2cl-lib:int-add k 1)) - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf l (f2cl-lib:int-sub kplus1 j)) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k))))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%))))))))))) - (t - (setf kx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (setf jx kx) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf kx (f2cl-lib:int-sub kx incx)) - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf ix kx) - (setf l (f2cl-lib:int-sub kplus1 j)) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k))))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx)))))) - (setf jx (f2cl-lib:int-sub jx incx))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf l (f2cl-lib:int-sub 1 j)) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k)))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%))))))))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf kx (f2cl-lib:int-add kx incx)) - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf ix kx) - (setf l (f2cl-lib:int-sub 1 j)) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k)))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))))) - (setf jx (f2cl-lib:int-add jx incx))))))))) - (t - (cond - ((lsame uplo "U") - (setf kplus1 (f2cl-lib:int-add k 1)) - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf l (f2cl-lib:int-sub kplus1 j)) - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k)))) - (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp)))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf ix kx) - (setf l (f2cl-lib:int-sub kplus1 j)) - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k)))) - (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-add jx incx)) - (if (> j k) (setf kx (f2cl-lib:int-add kx incx)))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf l (f2cl-lib:int-sub 1 j)) - (f2cl-lib:fdo (i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k))) - (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp)))) - (t - (setf kx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (setf jx kx) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf ix kx) - (setf l (f2cl-lib:int-sub 1 j)) - (f2cl-lib:fdo (i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k))) - (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-sub jx incx)) - (if (>= (f2cl-lib:int-sub n j) k) - (setf kx (f2cl-lib:int-sub kx incx))))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dtbsv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - (array double-float (*)) fixnum - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dtpmv BLAS} -\pagehead{dtpmv}{dtpmv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero 0.0)) - (declare (type (double-float 0.0 0.0) zero)) - (defun dtpmv (uplo trans diag n ap x incx) - (declare (type (array double-float (*)) x ap) - (type fixnum incx n) - (type (simple-array character (*)) diag trans uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (trans character trans-%data% trans-%offset%) - (diag character diag-%data% diag-%offset%) - (ap double-float ap-%data% ap-%offset%) - (x double-float x-%data% x-%offset%)) - (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0) (kk 0) - (kx 0) (temp 0.0)) - (declare (type (member t nil) nounit) - (type fixnum i info ix j jx k kk kx) - (type (double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((and (not (lsame trans "N")) - (not (lsame trans "T")) - (not (lsame trans "C"))) - (setf info 2)) - ((and (not (lsame diag "U")) (not (lsame diag "N"))) - (setf info 3)) - ((< n 0) - (setf info 4)) - ((= incx 0) - (setf info 7))) - (cond - ((/= info 0) - (xerbla "DTPMV " info) - (go end_label))) - (if (= n 0) (go end_label)) - (setf nounit (lsame diag "N")) - (cond - ((<= incx 0) - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx)))) - ((/= incx 1) - (setf kx 1))) - (cond - ((lsame trans "N") - (cond - ((lsame uplo "U") - (setf kk 1) - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf k kk) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf k (f2cl-lib:int-add k 1)))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%)))))) - (setf kk (f2cl-lib:int-add kk j))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix kx) - (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - j - (f2cl-lib:int-sub - 2))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%)))))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf kk (f2cl-lib:int-add kk j))))))) - (t - (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf k kk) - (f2cl-lib:fdo (i n - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf k (f2cl-lib:int-sub k 1)))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-add - (f2cl-lib:int-sub kk n) - j)) - ((1 *)) - ap-%offset%)))))) - (setf kk - (f2cl-lib:int-sub kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1)))))) - (t - (setf kx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (setf jx kx) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix kx) - (f2cl-lib:fdo (k kk - (f2cl-lib:int-add k - (f2cl-lib:int-sub 1))) - ((> k - (f2cl-lib:int-add kk - (f2cl-lib:int-sub - (f2cl-lib:int-add - n - (f2cl-lib:int-sub - (f2cl-lib:int-add - j - 1)))))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx)))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-add - (f2cl-lib:int-sub kk n) - j)) - ((1 *)) - ap-%offset%)))))) - (setf jx (f2cl-lib:int-sub jx incx)) - (setf kk - (f2cl-lib:int-sub kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1)))))))))) - (t - (cond - ((lsame uplo "U") - (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)))) - (setf k (f2cl-lib:int-sub kk 1)) - (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))) - (setf k (f2cl-lib:int-sub k 1)))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp) - (setf kk (f2cl-lib:int-sub kk j))))) - (t - (setf jx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf ix jx) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)))) - (f2cl-lib:fdo (k - (f2cl-lib:int-add kk (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) - ((> k - (f2cl-lib:int-add kk - (f2cl-lib:int-sub j) - 1)) - nil) - (tagbody - (setf ix (f2cl-lib:int-sub ix incx)) - (setf temp - (+ temp - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-sub jx incx)) - (setf kk (f2cl-lib:int-sub kk j))))))) - (t - (setf kk 1) - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)))) - (setf k (f2cl-lib:int-add kk 1)) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))) - (setf k (f2cl-lib:int-add k 1)))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp) - (setf kk - (f2cl-lib:int-add kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1)))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf ix jx) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)))) - (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) - (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - n - (f2cl-lib:int-sub j))) - nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf temp - (+ temp - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-add jx incx)) - (setf kk - (f2cl-lib:int-add kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1))))))))))) - end_label - (return (values nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dtpmv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dtpsv BLAS} -\pagehead{dtpsv}{dtpsv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero 0.0)) - (declare (type (double-float 0.0 0.0) zero)) - (defun dtpsv (uplo trans diag n ap x incx) - (declare (type (array double-float (*)) x ap) - (type fixnum incx n) - (type (simple-array character (*)) diag trans uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (trans character trans-%data% trans-%offset%) - (diag character diag-%data% diag-%offset%) - (ap double-float ap-%data% ap-%offset%) - (x double-float x-%data% x-%offset%)) - (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0) (kk 0) - (kx 0) (temp 0.0)) - (declare (type (member t nil) nounit) - (type fixnum i info ix j jx k kk kx) - (type (double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((and (not (lsame trans "N")) - (not (lsame trans "T")) - (not (lsame trans "C"))) - (setf info 2)) - ((and (not (lsame diag "U")) (not (lsame diag "N"))) - (setf info 3)) - ((< n 0) - (setf info 4)) - ((= incx 0) - (setf info 7))) - (cond - ((/= info 0) - (xerbla "DTPSV " info) - (go end_label))) - (if (= n 0) (go end_label)) - (setf nounit (lsame diag "N")) - (cond - ((<= incx 0) - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx)))) - ((/= incx 1) - (setf kx 1))) - (cond - ((lsame trans "N") - (cond - ((lsame uplo "U") - (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf k (f2cl-lib:int-sub kk 1)) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf k (f2cl-lib:int-sub k 1)))))) - (setf kk (f2cl-lib:int-sub kk j))))) - (t - (setf jx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix jx) - (f2cl-lib:fdo (k - (f2cl-lib:int-add kk - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add k - (f2cl-lib:int-sub 1))) - ((> k - (f2cl-lib:int-add kk - (f2cl-lib:int-sub - j) - 1)) - nil) - (tagbody - (setf ix (f2cl-lib:int-sub ix incx)) - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))))))) - (setf jx (f2cl-lib:int-sub jx incx)) - (setf kk (f2cl-lib:int-sub kk j))))))) - (t - (setf kk 1) - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf k (f2cl-lib:int-add kk 1)) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf k (f2cl-lib:int-add k 1)))))) - (setf kk - (f2cl-lib:int-add kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1)))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix jx) - (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) - (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - n - (f2cl-lib:int-sub - j))) - nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))))))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf kk - (f2cl-lib:int-add kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1)))))))))) - (t - (cond - ((lsame uplo "U") - (setf kk 1) - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf k kk) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))) - (setf k (f2cl-lib:int-add k 1)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%)))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp) - (setf kk (f2cl-lib:int-add kk j))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf ix kx) - (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - j - (f2cl-lib:int-sub 2))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%)))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-add jx incx)) - (setf kk (f2cl-lib:int-add kk j))))))) - (t - (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf k kk) - (f2cl-lib:fdo (i n - (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))) - (setf k (f2cl-lib:int-sub k 1)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-add - (f2cl-lib:int-sub kk n) - j)) - ((1 *)) - ap-%offset%)))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp) - (setf kk - (f2cl-lib:int-sub kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1)))))) - (t - (setf kx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (setf jx kx) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf ix kx) - (f2cl-lib:fdo (k kk - (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) - ((> k - (f2cl-lib:int-add kk - (f2cl-lib:int-sub - (f2cl-lib:int-add n - (f2cl-lib:int-sub - (f2cl-lib:int-add - j - 1)))))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-add - (f2cl-lib:int-sub kk n) - j)) - ((1 *)) - ap-%offset%)))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-sub jx incx)) - (setf kk - (f2cl-lib:int-sub kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1))))))))))) - end_label - (return (values nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dtpsv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum) - :return-values '(nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; fixnum fixnum +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum +; (array double-float (*)) fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlarfb fortran-to-lisp::dlarft +; fortran-to-lisp::dorm2r fortran-to-lisp::xerbla +; fortran-to-lisp::ilaenv fortran-to-lisp::lsame)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dtrevc LAPACK} -\pagehead{dtrevc}{dtrevc} +%\pagehead{dtrevc}{dtrevc} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -45561,34 +58405,34 @@ Returns multiple values where: (return (values nil nil nil nil nil nil nil nil nil nil nil m nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dtrevc - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (array (member t nil) (*)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum fixnum - fixnum (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::m nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::ddot fortran-to-lisp::dgemv - fortran-to-lisp::idamax fortran-to-lisp::dcopy - fortran-to-lisp::daxpy fortran-to-lisp::dscal - fortran-to-lisp::dlaln2 fortran-to-lisp::dlabad - fortran-to-lisp::dlamch fortran-to-lisp::xerbla - fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dtrevc +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (array (member t nil) (*)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum fixnum +; fixnum (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::m nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::ddot fortran-to-lisp::dgemv +; fortran-to-lisp::idamax fortran-to-lisp::dcopy +; fortran-to-lisp::daxpy fortran-to-lisp::dscal +; fortran-to-lisp::dlaln2 fortran-to-lisp::dlabad +; fortran-to-lisp::dlamch fortran-to-lisp::xerbla +; fortran-to-lisp::lsame)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dtrexc LAPACK} -\pagehead{dtrexc}{dtrexc} +%\pagehead{dtrexc}{dtrexc} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -45917,1516 +58761,27 @@ Returns multiple values where: end_label (return (values nil nil nil nil nil nil ifst ilst nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dtrexc - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum fixnum - fixnum (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil nil fortran-to-lisp::ifst - fortran-to-lisp::ilst nil fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlaexc fortran-to-lisp::xerbla - fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dtrmm BLAS} -\pagehead{dtrmm}{dtrmm} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one 1.0) (zero 0.0)) - (declare (type (double-float 1.0 1.0) one) - (type (double-float 0.0 0.0) zero)) - (defun dtrmm (side uplo transa diag m n alpha a lda b ldb$) - (declare (type (array double-float (*)) b a) - (type (double-float) alpha) - (type fixnum ldb$ lda n m) - (type (simple-array character (*)) diag transa uplo side)) - (f2cl-lib:with-multi-array-data - ((side character side-%data% side-%offset%) - (uplo character uplo-%data% uplo-%offset%) - (transa character transa-%data% transa-%offset%) - (diag character diag-%data% diag-%offset%) - (a double-float a-%data% a-%offset%) - (b double-float b-%data% b-%offset%)) - (prog ((temp 0.0) (i 0) (info 0) (j 0) (k 0) (nrowa 0) (lside nil) - (nounit nil) (upper nil)) - (declare (type (double-float) temp) - (type fixnum i info j k nrowa) - (type (member t nil) lside nounit upper)) - (setf lside (lsame side "L")) - (cond - (lside - (setf nrowa m)) - (t - (setf nrowa n))) - (setf nounit (lsame diag "N")) - (setf upper (lsame uplo "U")) - (setf info 0) - (cond - ((and (not lside) (not (lsame side "R"))) - (setf info 1)) - ((and (not upper) (not (lsame uplo "L"))) - (setf info 2)) - ((and (not (lsame transa "N")) - (not (lsame transa "T")) - (not (lsame transa "C"))) - (setf info 3)) - ((and (not (lsame diag "U")) (not (lsame diag "N"))) - (setf info 4)) - ((< m 0) - (setf info 5)) - ((< n 0) - (setf info 6)) - ((< lda (max (the fixnum 1) (the fixnum nrowa))) - (setf info 9)) - ((< ldb$ (max (the fixnum 1) (the fixnum m))) - (setf info 11))) - (cond - ((/= info 0) - (xerbla "DTRMM " info) - (go end_label))) - (if (= n 0) (go end_label)) - (cond - ((= alpha zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - zero))))) - (go end_label))) - (cond - (lside - (cond - ((lsame transa "N") - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k m) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add k - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (+ - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i k) - ((1 lda) (1 *)) - a-%offset%)))))) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%)))) - (setf (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - temp)))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (k m - (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) - ((> k 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%))) - (setf (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - temp) - (if nounit - (setf (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (* - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i (f2cl-lib:int-add k 1) - (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (+ - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i k) - ((1 lda) (1 *)) - a-%offset%))))))))))))))) - (t - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i m - (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%)) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add i - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%)))))) - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* alpha temp))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%)) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) - (f2cl-lib:int-add k 1)) - ((> k m) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%)))))) - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* alpha temp))))))))))) - (t - (cond - ((lsame transa "N") - (cond - (upper - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp alpha) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))))) - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref a-%data% - (k j) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (+ - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%))))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp alpha) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))))) - (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) - (f2cl-lib:int-add k 1)) - ((> k n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref a-%data% - (k j) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (+ - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%))))))))))))))) - (t - (cond - (upper - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k n) nil) - (tagbody - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j - (f2cl-lib:int-add k - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref a-%data% - (j k) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (+ - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))))) - (setf temp alpha) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%)))) - (cond - ((/= temp one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))))) - (t - (f2cl-lib:fdo (k n (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) - ((> k 1) nil) - (tagbody - (f2cl-lib:fdo (j (f2cl-lib:int-add k 1) - (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref a-%data% - (j k) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (+ - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))))) - (setf temp alpha) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%)))) - (cond - ((/= temp one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%))))))))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dtrmm fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - (double-float) (array double-float (*)) - fixnum (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dtrmv BLAS} -\pagehead{dtrmv}{dtrmv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero 0.0)) - (declare (type (double-float 0.0 0.0) zero)) - (defun dtrmv (uplo trans diag n a lda x incx) - (declare (type (array double-float (*)) x a) - (type fixnum incx lda n) - (type (simple-array character (*)) diag trans uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (trans character trans-%data% trans-%offset%) - (diag character diag-%data% diag-%offset%) - (a double-float a-%data% a-%offset%) - (x double-float x-%data% x-%offset%)) - (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (kx 0) (temp 0.0)) - (declare (type (member t nil) nounit) - (type fixnum i info ix j jx kx) - (type (double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((and (not (lsame trans "N")) - (not (lsame trans "T")) - (not (lsame trans "C"))) - (setf info 2)) - ((and (not (lsame diag "U")) (not (lsame diag "N"))) - (setf info 3)) - ((< n 0) - (setf info 4)) - ((< lda (max (the fixnum 1) (the fixnum n))) - (setf info 6)) - ((= incx 0) - (setf info 8))) - (cond - ((/= info 0) - (xerbla "DTRMV " info) - (go end_label))) - (if (= n 0) (go end_label)) - (setf nounit (lsame diag "N")) - (cond - ((<= incx 0) - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx)))) - ((/= incx 1) - (setf kx 1))) - (cond - ((lsame trans "N") - (cond - ((lsame uplo "U") - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))))))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix kx) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))))) - (setf jx (f2cl-lib:int-add jx incx))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (f2cl-lib:fdo (i n - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))))))))) - (t - (setf kx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (setf jx kx) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix kx) - (f2cl-lib:fdo (i n - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx)))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))))) - (setf jx (f2cl-lib:int-sub jx incx))))))))) - (t - (cond - ((lsame uplo "U") - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp)))) - (t - (setf jx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf ix jx) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf ix (f2cl-lib:int-sub ix incx)) - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-sub jx incx))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp)))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf ix jx) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-add jx incx)))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dtrmv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dtrsm BLAS} -\pagehead{dtrsm}{dtrsm} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one 1.0) (zero 0.0)) - (declare (type (double-float 1.0 1.0) one) - (type (double-float 0.0 0.0) zero)) - (defun dtrsm (side uplo transa diag m n alpha a lda b ldb$) - (declare (type (array double-float (*)) b a) - (type (double-float) alpha) - (type fixnum ldb$ lda n m) - (type (simple-array character (*)) diag transa uplo side)) - (f2cl-lib:with-multi-array-data - ((side character side-%data% side-%offset%) - (uplo character uplo-%data% uplo-%offset%) - (transa character transa-%data% transa-%offset%) - (diag character diag-%data% diag-%offset%) - (a double-float a-%data% a-%offset%) - (b double-float b-%data% b-%offset%)) - (prog ((temp 0.0) (i 0) (info 0) (j 0) (k 0) (nrowa 0) (lside nil) - (nounit nil) (upper nil)) - (declare (type (double-float) temp) - (type fixnum i info j k nrowa) - (type (member t nil) lside nounit upper)) - (setf lside (lsame side "L")) - (cond - (lside - (setf nrowa m)) - (t - (setf nrowa n))) - (setf nounit (lsame diag "N")) - (setf upper (lsame uplo "U")) - (setf info 0) - (cond - ((and (not lside) (not (lsame side "R"))) - (setf info 1)) - ((and (not upper) (not (lsame uplo "L"))) - (setf info 2)) - ((and (not (lsame transa "N")) - (not (lsame transa "T")) - (not (lsame transa "C"))) - (setf info 3)) - ((and (not (lsame diag "U")) (not (lsame diag "N"))) - (setf info 4)) - ((< m 0) - (setf info 5)) - ((< n 0) - (setf info 6)) - ((< lda (max (the fixnum 1) (the fixnum nrowa))) - (setf info 9)) - ((< ldb$ (max (the fixnum 1) (the fixnum m))) - (setf info 11))) - (cond - ((/= info 0) - (xerbla "DTRSM " info) - (go end_label))) - (if (= n 0) (go end_label)) - (cond - ((= alpha zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - zero))))) - (go end_label))) - (cond - (lside - (cond - ((lsame transa "N") - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= alpha one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* alpha - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))))))) - (f2cl-lib:fdo (k m - (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) - ((> k 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) - (if nounit - (setf (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (/ - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add k - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (- - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:fref a-%data% - (i k) - ((1 lda) (1 *)) - a-%offset%))))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= alpha one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* alpha - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))))))) - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k m) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) - (if nounit - (setf (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (/ - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i (f2cl-lib:int-add k 1) - (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (- - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:fref a-%data% - (i k) - ((1 lda) (1 *)) - a-%offset%))))))))))))))) - (t - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp - (* alpha - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))) - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add i - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%)))))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%)))) - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - temp)))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i m - (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf temp - (* alpha - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))) - (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) - (f2cl-lib:int-add k 1)) - ((> k m) nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%)))))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%)))) - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - temp)))))))))) - (t - (cond - ((lsame transa "N") - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= alpha one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* alpha - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))))))) - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (- - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* - (f2cl-lib:fref a-%data% - (k j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))))) - (cond - (nounit - (setf temp - (/ one - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%)))))))))) - (t - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= alpha one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* alpha - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))))))) - (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) - (f2cl-lib:int-add k 1)) - ((> k n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (- - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* - (f2cl-lib:fref a-%data% - (k j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))))) - (cond - (nounit - (setf temp - (/ one - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%)))))))))))) - (t - (cond - (upper - (f2cl-lib:fdo (k n (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) - ((> k 1) nil) - (tagbody - (cond - (nounit - (setf temp - (/ one - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%))))))) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j - (f2cl-lib:int-add k - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) - (setf temp - (f2cl-lib:fref a-%data% - (j k) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (- - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))))) - (cond - ((/= alpha one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%) - (* alpha - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))))) - (t - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k n) nil) - (tagbody - (cond - (nounit - (setf temp - (/ one - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%))))))) - (f2cl-lib:fdo (j (f2cl-lib:int-add k 1) - (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) - (setf temp - (f2cl-lib:fref a-%data% - (j k) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (- - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))))) - (cond - ((/= alpha one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%) - (* alpha - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%))))))))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dtrsm fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - (double-float) (array double-float (*)) - fixnum (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dtrexc +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum fixnum +; fixnum (array double-float (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil fortran-to-lisp::ifst +; fortran-to-lisp::ilst nil fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlaexc fortran-to-lisp::xerbla +; fortran-to-lisp::lsame)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{dtrsna LAPACK} -\pagehead{dtrsna}{dtrsna} +%\pagehead{dtrsna}{dtrsna} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -48035,753 +59390,38 @@ Returns multiple values where: nil info)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dtrsna - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (array (member t nil) (*)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - (array double-float (*)) fixnum - fixnum (array double-float (*)) - fixnum - (array fixnum (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil - fortran-to-lisp::m nil nil nil - fortran-to-lisp::info) - :calls '(fortran-to-lisp::dlaqtr fortran-to-lisp::dlacon - fortran-to-lisp::dtrexc fortran-to-lisp::dlacpy - fortran-to-lisp::dlapy2 fortran-to-lisp::dnrm2 - fortran-to-lisp::ddot fortran-to-lisp::dlabad - fortran-to-lisp::dlamch fortran-to-lisp::xerbla - fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dtrsv BLAS} -\pagehead{dtrsv}{dtrsv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero 0.0)) - (declare (type (double-float 0.0 0.0) zero)) - (defun dtrsv (uplo trans diag n a lda x incx) - (declare (type (array double-float (*)) x a) - (type fixnum incx lda n) - (type (simple-array character (*)) diag trans uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (trans character trans-%data% trans-%offset%) - (diag character diag-%data% diag-%offset%) - (a double-float a-%data% a-%offset%) - (x double-float x-%data% x-%offset%)) - (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (kx 0) (temp 0.0)) - (declare (type (member t nil) nounit) - (type fixnum i info ix j jx kx) - (type (double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((and (not (lsame trans "N")) - (not (lsame trans "T")) - (not (lsame trans "C"))) - (setf info 2)) - ((and (not (lsame diag "U")) (not (lsame diag "N"))) - (setf info 3)) - ((< n 0) - (setf info 4)) - ((< lda (max (the fixnum 1) (the fixnum n))) - (setf info 6)) - ((= incx 0) - (setf info 8))) - (cond - ((/= info 0) - (xerbla "DTRSV " info) - (go end_label))) - (if (= n 0) (go end_label)) - (setf nounit (lsame diag "N")) - (cond - ((<= incx 0) - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx)))) - ((/= incx 1) - (setf kx 1))) - (cond - ((lsame trans "N") - (cond - ((lsame uplo "U") - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%))))))))))) - (t - (setf jx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix jx) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf ix (f2cl-lib:int-sub ix incx)) - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))))))) - (setf jx (f2cl-lib:int-sub jx incx))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%))))))))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix jx) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))))))) - (setf jx (f2cl-lib:int-add jx incx))))))))) - (t - (cond - ((lsame uplo "U") - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp)))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf ix kx) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-add jx incx))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (f2cl-lib:fdo (i n - (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp)))) - (t - (setf kx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (setf jx kx) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf ix kx) - (f2cl-lib:fdo (i n - (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-sub jx incx)))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dtrsv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum (array double-float (*)) - fixnum (array double-float (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dzasum BLAS} -\pagehead{dzasum}{dzasum} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -Computes (complex double-float) $asum \leftarrow ||re(x)||_1 + ||im(x)||_1$ - -Arguments are: -\begin{itemize} -\item n - fixnum -\item dx - array (complex double-float) -\item incx - fixnum -\end{itemize} - -Return values are: -\begin{itemize} -\item 1 nil -\item 2 nil -\item 3 nil -\end{itemize} - -<>= -(defun dzasum (n zx incx) - (declare (type (array (complex double-float) (*)) zx) - (type fixnum incx n)) - (f2cl-lib:with-multi-array-data - ((zx (complex double-float) zx-%data% zx-%offset%)) - (prog ((i 0) (ix 0) (stemp 0.0) (dzasum 0.0)) - (declare (type (double-float) dzasum stemp) - (type fixnum ix i)) - (setf dzasum 0.0) - (setf stemp 0.0) - (if (or (<= n 0) (<= incx 0)) (go end_label)) - (if (= incx 1) (go label20)) - (setf ix 1) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf stemp - (+ stemp - (dcabs1 - (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))) - (setf dzasum stemp) - (go end_label) - label20 - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf stemp - (+ stemp - (dcabs1 - (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%)))))) - (setf dzasum stemp) - end_label - (return (values dzasum nil nil nil))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dzasum - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil) - :calls '(fortran-to-lisp::dcabs1)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{dznrm2 BLAS} -\pagehead{dznrm2}{dznrm2} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one 1.0) (zero 0.0)) - (declare (type (double-float 1.0 1.0) one) - (type (double-float 0.0 0.0) zero)) - (defun dznrm2 (n x incx) - (declare (type (array (complex double-float) (*)) x) - (type fixnum incx n)) - (f2cl-lib:with-multi-array-data - ((x (complex double-float) x-%data% x-%offset%)) - (prog ((norm 0.0) (scale 0.0) (ssq 0.0) (temp 0.0) (ix 0) (dznrm2 0.0)) - (declare (type fixnum ix) - (type (double-float) norm scale ssq temp dznrm2)) - (cond - ((or (< n 1) (< incx 1)) - (setf norm zero)) - (t - (setf scale zero) - (setf ssq one) - (f2cl-lib:fdo (ix 1 (f2cl-lib:int-add ix incx)) - ((> ix - (f2cl-lib:int-add 1 - (f2cl-lib:int-mul - (f2cl-lib:int-add n - (f2cl-lib:int-sub 1)) - incx))) - nil) - (tagbody - (cond - ((/= - (coerce (realpart (f2cl-lib:fref x (ix) ((1 *)))) 'double-float) - zero) - (setf temp - (abs - (coerce (realpart - (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%)) - 'double-float))) - (cond - ((< scale temp) - (setf ssq (+ one (* ssq (expt (/ scale temp) 2)))) - (setf scale temp)) - (t - (setf ssq (+ ssq (expt (/ temp scale) 2))))))) - (cond - ((/= (f2cl-lib:dimag (f2cl-lib:fref x (ix) ((1 *)))) zero) - (setf temp - (abs - (f2cl-lib:dimag - (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%)))) - (cond - ((< scale temp) - (setf ssq (+ one (* ssq (expt (/ scale temp) 2)))) - (setf scale temp)) - (t - (setf ssq (+ ssq (expt (/ temp scale) 2))))))))) - (setf norm (* scale (f2cl-lib:fsqrt ssq))))) - (setf dznrm2 norm) - end_label - (return (values dznrm2 nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::dznrm2 - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil) - :calls 'nil))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter E} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter F} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter G} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter H} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter I} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{icamax BLAS} -\pagehead{icamax}{icamax} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(defun icamax (n cx incx) - (declare (type (array (complex single-float) (*)) cx) - (type fixnum incx n)) - (f2cl-lib:with-multi-array-data - ((cx (complex single-float) cx-%data% cx-%offset%)) - (labels ((cabs1 (zdum) - (+ (abs (coerce (realpart zdum) 'single-float)) - (abs (f2cl-lib:aimag zdum))))) - (declare (ftype (function (complex single-float) - (values single-float &rest t)) - cabs1)) - (prog ((zdum #C(0.0f0 0.0f0)) (i 0) (ix 0) (smax 0.0f0) (icamax 0)) - (declare (type (single-float) smax) - (type fixnum icamax ix i) - (type (complex single-float) zdum)) - (setf icamax 0) - (if (or (< n 1) (<= incx 0)) (go end_label)) - (setf icamax 1) - (if (= n 1) (go end_label)) - (if (= incx 1) (go label20)) - (setf ix 1) - (setf smax (cabs1 (f2cl-lib:fref cx-%data% (1) ((1 *)) cx-%offset%))) - (setf ix (f2cl-lib:int-add ix incx)) - (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (if - (<= (cabs1 (f2cl-lib:fref cx-%data% (ix) ((1 *)) cx-%offset%)) - smax) - (go label5)) - (setf icamax i) - (setf smax - (cabs1 (f2cl-lib:fref cx-%data% (ix) ((1 *)) cx-%offset%))) - label5 - (setf ix (f2cl-lib:int-add ix incx)))) - (go end_label) - label20 - (setf smax (cabs1 (f2cl-lib:fref cx-%data% (1) ((1 *)) cx-%offset%))) - (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (if - (<= (cabs1 (f2cl-lib:fref cx-%data% (i) ((1 *)) cx-%offset%)) - smax) - (go label30)) - (setf icamax i) - (setf smax - (cabs1 (f2cl-lib:fref cx-%data% (i) ((1 *)) cx-%offset%))) - label30)) - end_label - (return (values icamax nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::icamax - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum - (array (complex single-float) (*)) - fixnum) - :return-values '(nil nil nil) - :calls 'nil))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{idamax BLAS} -\pagehead{idamax}{idamax} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(defun idamax (n dx incx) - (declare (type (array double-float (*)) dx) - (type fixnum incx n)) - (f2cl-lib:with-multi-array-data - ((dx double-float dx-%data% dx-%offset%)) - (prog ((i 0) (ix 0) (dmax 0.0) (idamax 0)) - (declare (type (double-float) dmax) - (type fixnum idamax ix i)) - (setf idamax 0) - (if (or (< n 1) (<= incx 0)) (go end_label)) - (setf idamax 1) - (if (= n 1) (go end_label)) - (if (= incx 1) (go label20)) - (setf ix 1) - (setf dmax - (the double-float (abs - (the double-float - (f2cl-lib:fref dx-%data% (1) ((1 *)) dx-%offset%))))) - (setf ix (f2cl-lib:int-add ix incx)) - (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (if - (<= - (the double-float (abs - (the double-float - (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%)))) - dmax) - (go label5)) - (setf idamax i) - (setf dmax - (the double-float (abs - (the double-float - (f2cl-lib:fref dx-%data% (ix) ((1 *)) dx-%offset%))))) - label5 - (setf ix (f2cl-lib:int-add ix incx)))) - (go end_label) - label20 - (setf dmax - (the double-float (abs - (the double-float - (f2cl-lib:fref dx-%data% (1) ((1 *)) dx-%offset%))))) - (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (if - (<= - (the double-float (abs - (the double-float - (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%)))) - dmax) - (go label30)) - (setf idamax i) - (setf dmax - (the double-float (abs - (the double-float - (f2cl-lib:fref dx-%data% (i) ((1 *)) dx-%offset%))))) - label30)) - end_label - (return (values idamax nil nil nil))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::idamax - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum (array double-float (*)) - fixnum) - :return-values '(nil nil nil) - :calls 'nil))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::dtrsna +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; (simple-array character (1)) +; (array (member t nil) (*)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; fixnum (array double-float (*)) +; (array double-float (*)) fixnum +; fixnum (array double-float (*)) +; fixnum +; (array fixnum (*)) +; fixnum) +; :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil nil +; fortran-to-lisp::m nil nil nil +; fortran-to-lisp::info) +; :calls '(fortran-to-lisp::dlaqtr fortran-to-lisp::dlacon +; fortran-to-lisp::dtrexc fortran-to-lisp::dlacpy +; fortran-to-lisp::dlapy2 fortran-to-lisp::dnrm2 +; fortran-to-lisp::ddot fortran-to-lisp::dlabad +; fortran-to-lisp::dlamch fortran-to-lisp::xerbla +; fortran-to-lisp::lsame)))); @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{ieeeck LAPACK} -\pagehead{ieeeck}{ieeeck} +%\pagehead{ieeeck}{ieeeck} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -48868,21 +59508,21 @@ Return values are: end_label (return (values ieeeck nil nil nil)))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::ieeeck - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum (single-float) - (single-float)) - :return-values '(nil nil nil) - :calls 'nil))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::ieeeck +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum (single-float) +; (single-float)) +; :return-values '(nil nil nil) +; :calls 'nil)));; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{ilaenv LAPACK} -\pagehead{ilaenv}{ilaenv} +%\pagehead{ilaenv}{ilaenv} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -49330,6204 +59970,25 @@ Return values are: end_label (return (values ilaenv nil nil nil nil nil nil nil))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::ilaenv - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum - (simple-array character (*)) - (simple-array character (*)) - fixnum fixnum - fixnum - fixnum) - :return-values '(nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::ieeeck)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{isamax BLAS} -\pagehead{isamax}{isamax} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(defun isamax (n sx incx) - (declare (type (array single-float (*)) sx) - (type fixnum incx n)) - (f2cl-lib:with-multi-array-data - ((sx single-float sx-%data% sx-%offset%)) - (prog ((i 0) (ix 0) (smax 0.0f0) (isamax 0)) - (declare (type (single-float) smax) - (type fixnum isamax ix i)) - (setf isamax 0) - (if (or (< n 1) (<= incx 0)) (go end_label)) - (setf isamax 1) - (if (= n 1) (go end_label)) - (if (= incx 1) (go label20)) - (setf ix 1) - (setf smax (abs (f2cl-lib:fref sx-%data% (1) ((1 *)) sx-%offset%))) - (setf ix (f2cl-lib:int-add ix incx)) - (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (if - (<= (abs (f2cl-lib:fref sx-%data% (ix) ((1 *)) sx-%offset%)) smax) - (go label5)) - (setf isamax i) - (setf smax (abs (f2cl-lib:fref sx-%data% (ix) ((1 *)) sx-%offset%))) - label5 - (setf ix (f2cl-lib:int-add ix incx)))) - (go end_label) - label20 - (setf smax (abs (f2cl-lib:fref sx-%data% (1) ((1 *)) sx-%offset%))) - (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (if (<= (abs (f2cl-lib:fref sx-%data% (i) ((1 *)) sx-%offset%)) smax) - (go label30)) - (setf isamax i) - (setf smax (abs (f2cl-lib:fref sx-%data% (i) ((1 *)) sx-%offset%))) - label30)) - end_label - (return (values isamax nil nil nil))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::isamax - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum (array single-float (*)) - fixnum) - :return-values '(nil nil nil) - :calls 'nil))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{izamax BLAS} -\pagehead{izamax}{izamax} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(defun izamax (n zx incx) - (declare (type (array (complex double-float) (*)) zx) - (type fixnum incx n)) - (f2cl-lib:with-multi-array-data - ((zx (complex double-float) zx-%data% zx-%offset%)) - (prog ((i 0) (ix 0) (smax 0.0) (izamax 0)) - (declare (type (double-float) smax) - (type fixnum izamax ix i)) - (setf izamax 0) - (if (or (< n 1) (<= incx 0)) (go end_label)) - (setf izamax 1) - (if (= n 1) (go end_label)) - (if (= incx 1) (go label20)) - (setf ix 1) - (setf smax (dcabs1 (f2cl-lib:fref zx-%data% (1) ((1 *)) zx-%offset%))) - (setf ix (f2cl-lib:int-add ix incx)) - (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (if - (<= (dcabs1 (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%)) - smax) - (go label5)) - (setf izamax i) - (setf smax - (dcabs1 (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%))) - label5 - (setf ix (f2cl-lib:int-add ix incx)))) - (go end_label) - label20 - (setf smax (dcabs1 (f2cl-lib:fref zx-%data% (1) ((1 *)) zx-%offset%))) - (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (if - (<= (dcabs1 (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%)) smax) - (go label30)) - (setf izamax i) - (setf smax - (dcabs1 (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%))) - label30)) - end_label - (return (values izamax nil nil nil))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::izamax - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil) - :calls '(fortran-to-lisp::dcabs1)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter J} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter K} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter L} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{lsame BLAS} -\pagehead{lsame}{lsame} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(defun lsame (ca cb) - (declare (type (simple-array character (*)) cb ca)) - (f2cl-lib:with-multi-array-data - ((ca character ca-%data% ca-%offset%) - (cb character cb-%data% cb-%offset%)) - (prog ((inta 0) (intb 0) (zcode 0) (lsame nil)) - (declare (type (member t nil) lsame) - (type fixnum zcode intb inta)) - (setf lsame (coerce (f2cl-lib:fstring-= ca cb) '(member t nil))) - (unless lsame - (setf zcode (f2cl-lib:ichar "Z")) - (setf inta (f2cl-lib:ichar ca)) - (setf intb (f2cl-lib:ichar cb)) - (cond - ((or (= zcode 90) (= zcode 122)) - (if (and (>= inta 97) (<= inta 122)) - (setf inta (f2cl-lib:int-sub inta 32))) - (if (and (>= intb 97) (<= intb 122)) - (setf intb (f2cl-lib:int-sub intb 32)))) - ((or (= zcode 233) (= zcode 169)) - (if - (or (and (>= inta 129) (<= inta 137)) - (and (>= inta 145) (<= inta 153)) - (and (>= inta 162) (<= inta 169))) - (setf inta (f2cl-lib:int-add inta 64))) - (if - (or (and (>= intb 129) (<= intb 137)) - (and (>= intb 145) (<= intb 153)) - (and (>= intb 162) (<= intb 169))) - (setf intb (f2cl-lib:int-add intb 64)))) - ((or (= zcode 218) (= zcode 250)) - (if (and (>= inta 225) (<= inta 250)) - (setf inta (f2cl-lib:int-sub inta 32))) - (if (and (>= intb 225) (<= intb 250)) - (setf intb (f2cl-lib:int-sub intb 32))))) - (setf lsame (coerce (= inta intb) '(member t nil)))) - (return (values lsame nil nil))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::lsame fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1))) - :return-values '(nil nil) - :calls 'nil))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter M} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter N} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter O} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter P} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter Q} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter R} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter S} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter T} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter U} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter V} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter W} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter X} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{xerbla BLAS} -\pagehead{xerbla}{xerbla} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(defun xerbla (srname info) - (declare (type fixnum info) - (type (simple-array character (*)) srname)) - (f2cl-lib:with-multi-array-data - ((srname character srname-%data% srname-%offset%)) - (prog () - (declare) - (format t - " ** On entry to ~a parameter number ~a had an illegal value~%" - srname info) - (return (values nil nil))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::xerbla - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (6)) - fixnum) - :return-values '(nil nil) - :calls 'nil))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter Y} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter Z} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zaxpy BLAS} -\pagehead{zaxpy}{zaxpy} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -Computes (complex double-float) $y \leftarrow \alpha{}x + y$ - -Arguments are: -\begin{itemize} -\item n - fixnum -\item da - (complex double-float) -\item dx - array (complex double-float) -\item incx - fixnum -\item dy - array (complex double-float) -\item incy - fixnum -\end{itemize} - -Return values are: -\begin{itemize} -\item 1 nil -\item 2 nil -\item 3 nil -\item 4 nil -\item 5 nil -\item 6 nil -\end{itemize} - -<>= -(defun zaxpy (n za zx incx zy incy) - (declare (type (array (complex double-float) (*)) zy zx) - (type (complex double-float) za) - (type fixnum incy incx n)) - (f2cl-lib:with-multi-array-data - ((zx (complex double-float) zx-%data% zx-%offset%) - (zy (complex double-float) zy-%data% zy-%offset%)) - (prog ((i 0) (ix 0) (iy 0)) - (declare (type fixnum iy ix i)) - (if (<= n 0) (go end_label)) - (if (= (dcabs1 za) 0.0) (go end_label)) - (if (and (= incx 1) (= incy 1)) (go label20)) - (setf ix 1) - (setf iy 1) - (if (< incx 0) - (setf ix - (f2cl-lib:int-add - (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) - 1))) - (if (< incy 0) - (setf iy - (f2cl-lib:int-add - (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) - 1))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref zy-%data% (iy) ((1 *)) zy-%offset%) - (+ (f2cl-lib:fref zy-%data% (iy) ((1 *)) zy-%offset%) - (* za - (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))) - (go end_label) - label20 - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%) - (+ (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%) - (* za (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%)))))) - end_label - (return (values nil nil nil nil nil nil))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zaxpy fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil) - :calls '(fortran-to-lisp::dcabs1)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zcopy BLAS} -\pagehead{zcopy}{zcopy} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(defun zcopy (n zx incx zy incy) - (declare (type (array (complex double-float) (*)) zy zx) - (type fixnum incy incx n)) - (f2cl-lib:with-multi-array-data - ((zx (complex double-float) zx-%data% zx-%offset%) - (zy (complex double-float) zy-%data% zy-%offset%)) - (prog ((i 0) (ix 0) (iy 0)) - (declare (type fixnum iy ix i)) - (if (<= n 0) (go end_label)) - (if (and (= incx 1) (= incy 1)) (go label20)) - (setf ix 1) - (setf iy 1) - (if (< incx 0) - (setf ix - (f2cl-lib:int-add - (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) - 1))) - (if (< incy 0) - (setf iy - (f2cl-lib:int-add - (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) - 1))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref zy-%data% (iy) ((1 *)) zy-%offset%) - (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%)) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))) - (go end_label) - label20 - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%) - (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%)))) - end_label - (return (values nil nil nil nil nil))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zcopy fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil) - :calls 'nil))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zdotc BLAS} -\pagehead{zdotc}{zdotc} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(defun zdotc (n zx incx zy incy) - (declare (type (array (complex double-float) (*)) zy zx) - (type fixnum incy incx n)) - (f2cl-lib:with-multi-array-data - ((zx (complex double-float) zx-%data% zx-%offset%) - (zy (complex double-float) zy-%data% zy-%offset%)) - (prog ((i 0) (ix 0) (iy 0) (ztemp #C(0.0 0.0)) (zdotc #C(0.0 0.0))) - (declare (type (complex double-float) zdotc ztemp) - (type fixnum iy ix i)) - (setf ztemp (complex 0.0 0.0)) - (setf zdotc (complex 0.0 0.0)) - (if (<= n 0) (go end_label)) - (if (and (= incx 1) (= incy 1)) (go label20)) - (setf ix 1) - (setf iy 1) - (if (< incx 0) - (setf ix - (f2cl-lib:int-add - (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) - 1))) - (if (< incy 0) - (setf iy - (f2cl-lib:int-add - (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) - 1))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf ztemp - (+ ztemp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%)) - (f2cl-lib:fref zy-%data% (iy) ((1 *)) zy-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))) - (setf zdotc ztemp) - (go end_label) - label20 - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf ztemp - (+ ztemp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%)) - (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%)))))) - (setf zdotc ztemp) - end_label - (return (values zdotc nil nil nil nil nil))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zdotc fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil) - :calls 'nil))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zdotu BLAS} -\pagehead{zdotu}{zdotu} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(defun zdotu (n zx incx zy incy) - (declare (type (array (complex double-float) (*)) zy zx) - (type fixnum incy incx n)) - (f2cl-lib:with-multi-array-data - ((zx (complex double-float) zx-%data% zx-%offset%) - (zy (complex double-float) zy-%data% zy-%offset%)) - (prog ((i 0) (ix 0) (iy 0) (ztemp #C(0.0 0.0)) (zdotu #C(0.0 0.0))) - (declare (type (complex double-float) zdotu ztemp) - (type fixnum iy ix i)) - (setf ztemp (complex 0.0 0.0)) - (setf zdotu (complex 0.0 0.0)) - (if (<= n 0) (go end_label)) - (if (and (= incx 1) (= incy 1)) (go label20)) - (setf ix 1) - (setf iy 1) - (if (< incx 0) - (setf ix - (f2cl-lib:int-add - (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) - 1))) - (if (< incy 0) - (setf iy - (f2cl-lib:int-add - (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) - 1))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf ztemp - (+ ztemp - (* (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%) - (f2cl-lib:fref zy-%data% (iy) ((1 *)) zy-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))) - (setf zdotu ztemp) - (go end_label) - label20 - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf ztemp - (+ ztemp - (* (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%) - (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%)))))) - (setf zdotu ztemp) - end_label - (return (values zdotu nil nil nil nil nil))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zdotu fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil) - :calls 'nil))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zdscal BLAS} -\pagehead{zdscal}{zdscal} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(defun zdscal (n da zx incx) - (declare (type (array (complex double-float) (*)) zx) - (type (double-float) da) - (type fixnum incx n)) - (f2cl-lib:with-multi-array-data - ((zx (complex double-float) zx-%data% zx-%offset%)) - (prog ((i 0) (ix 0)) - (declare (type fixnum ix i)) - (if (or (<= n 0) (<= incx 0)) (go end_label)) - (if (= incx 1) (go label20)) - (setf ix 1) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%) - (* (coerce (complex da 0.0) '(complex doublefloat)) - (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%))) - (setf ix (f2cl-lib:int-add ix incx)))) - (go end_label) - label20 - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%) - (* (coerce (complex da 0.0) '(complex double-float)) - (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%))))) - end_label - (return (values nil nil nil nil))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zdscal - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum (double-float) - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil) - :calls 'nil))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zgbmv BLAS} -\pagehead{zgbmv}{zgbmv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) - (declare (type (complex double-float) one) (type (complex double-float) zero)) - (defun zgbmv (trans m n kl ku alpha a lda x incx beta y incy) - (declare (type (array (complex double-float) (*)) y x a) - (type (complex double-float) beta alpha) - (type fixnum incy incx lda ku kl n m) - (type (simple-array character (*)) trans)) - (f2cl-lib:with-multi-array-data - ((trans character trans-%data% trans-%offset%) - (a (complex double-float) a-%data% a-%offset%) - (x (complex double-float) x-%data% x-%offset%) - (y (complex double-float) y-%data% y-%offset%)) - (prog ((noconj nil) (i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) - (k 0) (kup1 0) (kx 0) (ky 0) (lenx 0) (leny 0) (temp #C(0.0 0.0))) - (declare (type (member t nil) noconj) - (type fixnum i info ix iy j jx jy k kup1 kx ky - lenx leny) - (type (complex double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame trans "N")) - (not (lsame trans "T")) - (not (lsame trans "C"))) - (setf info 1)) - ((< m 0) - (setf info 2)) - ((< n 0) - (setf info 3)) - ((< kl 0) - (setf info 4)) - ((< ku 0) - (setf info 5)) - ((< lda (f2cl-lib:int-add kl ku 1)) - (setf info 8)) - ((= incx 0) - (setf info 10)) - ((= incy 0) - (setf info 13))) - (cond - ((/= info 0) - (xerbla "ZGBMV " info) - (go end_label))) - (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one))) - (go end_label)) - (setf noconj (lsame trans "T")) - (cond - ((lsame trans "N") - (setf lenx n) - (setf leny m)) - (t - (setf lenx m) - (setf leny n))) - (cond - ((> incx 0) - (setf kx 1)) - (t - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul - (f2cl-lib:int-sub lenx 1) - incx))))) - (cond - ((> incy 0) - (setf ky 1)) - (t - (setf ky - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul - (f2cl-lib:int-sub leny 1) - incy))))) - (cond - ((/= beta one) - (cond - ((= incy 1) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i leny) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - zero)))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i leny) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%)))))))) - (t - (setf iy ky) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i leny) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - zero) - (setf iy (f2cl-lib:int-add iy incy))))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i leny) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%))) - (setf iy (f2cl-lib:int-add iy incy)))))))))) - (if (= alpha zero) (go end_label)) - (setf kup1 (f2cl-lib:int-add ku 1)) - (cond - ((lsame trans "N") - (setf jx kx) - (cond - ((= incy 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - (setf k (f2cl-lib:int-sub kup1 j)) - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - ku)))) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum m) - (the fixnum - (f2cl-lib:int-add j kl)))) - nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add k i) j) - ((1 lda) (1 *)) - a-%offset%)))))))) - (setf jx (f2cl-lib:int-add jx incx))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - (setf iy ky) - (setf k (f2cl-lib:int-sub kup1 j)) - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - ku)))) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum m) - (the fixnum - (f2cl-lib:int-add j kl)))) - nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add k i) j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf iy (f2cl-lib:int-add iy incy)))))) - (setf jx (f2cl-lib:int-add jx incx)) - (if (> j ku) (setf ky (f2cl-lib:int-add ky incy)))))))) - (t - (setf jy ky) - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp zero) - (setf k (f2cl-lib:int-sub kup1 j)) - (cond - (noconj - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - ku)))) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum m) - (the fixnum - (f2cl-lib:int-add j kl)))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add k i) j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%))))))) - (t - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - ku)))) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum m) - (the fixnum - (f2cl-lib:int-add j kl)))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add k i) j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* alpha temp))) - (setf jy (f2cl-lib:int-add jy incy))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp zero) - (setf ix kx) - (setf k (f2cl-lib:int-sub kup1 j)) - (cond - (noconj - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - ku)))) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum m) - (the fixnum - (f2cl-lib:int-add j kl)))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add k i) j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx))))) - (t - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - ku)))) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum m) - (the fixnum - (f2cl-lib:int-add j kl)))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add k i) j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* alpha temp))) - (setf jy (f2cl-lib:int-add jy incy)) - (if (> j ku) (setf kx (f2cl-lib:int-add kx incx))))))))) - end_label - (return - (values nil nil nil nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zgbmv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum fixnum - fixnum fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil - nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zgemm BLAS} -\pagehead{zgemm}{zgemm} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) - (declare (type (complex double-float) one) (type (complex double-float) zero)) - (defun zgemm (transa transb m n k alpha a lda b ldb$ beta c ldc) - (declare (type (array (complex double-float) (*)) c b a) - (type (complex double-float) beta alpha) - (type fixnum ldc ldb$ lda k n m) - (type (simple-array character (*)) transb transa)) - (f2cl-lib:with-multi-array-data - ((transa character transa-%data% transa-%offset%) - (transb character transb-%data% transb-%offset%) - (a (complex double-float) a-%data% a-%offset%) - (b (complex double-float) b-%data% b-%offset%) - (c (complex double-float) c-%data% c-%offset%)) - (prog ((temp #C(0.0 0.0)) (i 0) (info 0) (j 0) (l 0) (ncola 0) (nrowa 0) - (nrowb 0) (conja nil) (conjb nil) (nota nil) (notb nil)) - (declare (type (complex double-float) temp) - (type fixnum i info j l ncola nrowa nrowb) - (type (member t nil) conja conjb nota notb)) - (setf nota (lsame transa "N")) - (setf notb (lsame transb "N")) - (setf conja (lsame transa "C")) - (setf conjb (lsame transb "C")) - (cond - (nota - (setf nrowa m) - (setf ncola k)) - (t - (setf nrowa k) - (setf ncola m))) - (cond - (notb - (setf nrowb k)) - (t - (setf nrowb n))) - (setf info 0) - (cond - ((and (not nota) (not conja) (not (lsame transa "T"))) - (setf info 1)) - ((and (not notb) (not conjb) (not (lsame transb "T"))) - (setf info 2)) - ((< m 0) - (setf info 3)) - ((< n 0) - (setf info 4)) - ((< k 0) - (setf info 5)) - ((< lda (max (the fixnum 1) (the fixnum nrowa))) - (setf info 8)) - ((< ldb$ - (max (the fixnum 1) (the fixnum nrowb))) - (setf info 10)) - ((< ldc (max (the fixnum 1) (the fixnum m))) - (setf info 13))) - (cond - ((/= info 0) - (xerbla "ZGEMM " info) - (go end_label))) - (if (or (= m 0) (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) - (go end_label)) - (cond - ((= alpha zero) - (cond - ((= beta zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))))) - (go end_label))) - (cond - (notb - (cond - (nota - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))) - ((/= beta one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref b (l j) ((1 ldb$) (1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref b-%data% - (l j) - ((1 ldb$) (1 *)) - b-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i l) - ((1 lda) (1 *)) - a-%offset%))))))))))))) - (conja - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref b-%data% - (l j) - ((1 ldb$) (1 *)) - b-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* alpha temp))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (l j) - ((1 ldb$) (1 *)) - b-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* alpha temp))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))))))))) - (nota - (cond - (conjb - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))) - ((/= beta one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref b-%data% - (j l) - ((1 ldb$) (1 *)) - b-%offset%)))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i l) - ((1 lda) (1 *)) - a-%offset%))))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))) - ((/= beta one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref b-%data% - (j l) - ((1 ldb$) (1 *)) - b-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i l) - ((1 lda) (1 *)) - a-%offset%))))))))))))))) - (conja - (cond - (conjb - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:dconjg - (f2cl-lib:fref b-%data% - (j l) - ((1 ldb$) (1 *)) - b-%offset%))))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* alpha temp))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref b-%data% - (j l) - ((1 ldb$) (1 *)) - b-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* alpha temp))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))))))))) - (t - (cond - (conjb - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:dconjg - (f2cl-lib:fref b-%data% - (j l) - ((1 ldb$) (1 *)) - b-%offset%))))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* alpha temp))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (j l) - ((1 ldb$) (1 *)) - b-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* alpha temp))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)))))))))))))) - end_label - (return - (values nil nil nil nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zgemm fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil - nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zgemv BLAS} -\pagehead{zgemv}{zgemv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) - (declare (type (complex double-float) one) (type (complex double-float) zero)) - (defun zgemv (trans m n alpha a lda x incx beta y incy) - (declare (type (array (complex double-float) (*)) y x a) - (type (complex double-float) beta alpha) - (type fixnum incy incx lda n m) - (type (simple-array character (*)) trans)) - (f2cl-lib:with-multi-array-data - ((trans character trans-%data% trans-%offset%) - (a (complex double-float) a-%data% a-%offset%) - (x (complex double-float) x-%data% x-%offset%) - (y (complex double-float) y-%data% y-%offset%)) - (prog ((noconj nil) (i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) - (kx 0) (ky 0) (lenx 0) (leny 0) (temp #C(0.0 0.0))) - (declare (type (member t nil) noconj) - (type fixnum i info ix iy j jx jy kx ky lenx - leny) - (type (complex double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame trans "N")) - (not (lsame trans "T")) - (not (lsame trans "C"))) - (setf info 1)) - ((< m 0) - (setf info 2)) - ((< n 0) - (setf info 3)) - ((< lda (max (the fixnum 1) (the fixnum m))) - (setf info 6)) - ((= incx 0) - (setf info 8)) - ((= incy 0) - (setf info 11))) - (cond - ((/= info 0) - (xerbla "ZGEMV " info) - (go end_label))) - (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one))) - (go end_label)) - (setf noconj (lsame trans "T")) - (cond - ((lsame trans "N") - (setf lenx n) - (setf leny m)) - (t - (setf lenx m) - (setf leny n))) - (cond - ((> incx 0) - (setf kx 1)) - (t - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul - (f2cl-lib:int-sub lenx 1) - incx))))) - (cond - ((> incy 0) - (setf ky 1)) - (t - (setf ky - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul - (f2cl-lib:int-sub leny 1) - incy))))) - (cond - ((/= beta one) - (cond - ((= incy 1) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i leny) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - zero)))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i leny) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%)))))))) - (t - (setf iy ky) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i leny) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - zero) - (setf iy (f2cl-lib:int-add iy incy))))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i leny) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%))) - (setf iy (f2cl-lib:int-add iy incy)))))))))) - (if (= alpha zero) (go end_label)) - (cond - ((lsame trans "N") - (setf jx kx) - (cond - ((= incy 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))))))) - (setf jx (f2cl-lib:int-add jx incx))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - (setf iy ky) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf iy (f2cl-lib:int-add iy incy)))))) - (setf jx (f2cl-lib:int-add jx incx))))))) - (t - (setf jy ky) - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp zero) - (cond - (noconj - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%))))))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* alpha temp))) - (setf jy (f2cl-lib:int-add jy incy))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp zero) - (setf ix kx) - (cond - (noconj - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx))))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* alpha temp))) - (setf jy (f2cl-lib:int-add jy incy)))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zgemv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zgerc BLAS} -\pagehead{zgerc}{zgerc} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero (complex 0.0 0.0))) - (declare (type (complex double-float) zero)) - (defun zgerc (m n alpha x incx y incy a lda) - (declare (type (array (complex double-float) (*)) a y x) - (type (complex double-float) alpha) - (type fixnum lda incy incx n m)) - (f2cl-lib:with-multi-array-data - ((x (complex double-float) x-%data% x-%offset%) - (y (complex double-float) y-%data% y-%offset%) - (a (complex double-float) a-%data% a-%offset%)) - (prog ((i 0) (info 0) (ix 0) (j 0) (jy 0) (kx 0) (temp #C(0.0 0.0))) - (declare (type fixnum i info ix j jy kx) - (type (complex double-float) temp)) - (setf info 0) - (cond - ((< m 0) - (setf info 1)) - ((< n 0) - (setf info 2)) - ((= incx 0) - (setf info 5)) - ((= incy 0) - (setf info 7)) - ((< lda (max (the fixnum 1) (the fixnum m))) - (setf info 9))) - (cond - ((/= info 0) - (xerbla "ZGERC " info) - (go end_label))) - (if (or (= m 0) (= n 0) (= alpha zero)) (go end_label)) - (cond - ((> incy 0) - (setf jy 1)) - (t - (setf jy - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incy))))) - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref y (jy) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref y-%data% - (jy) - ((1 *)) - y-%offset%)))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%) - temp))))))) - (setf jy (f2cl-lib:int-add jy incy))))) - (t - (cond - ((> incx 0) - (setf kx 1)) - (t - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul - (f2cl-lib:int-sub m 1) - incx))))) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref y (jy) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref y-%data% - (jy) - ((1 *)) - y-%offset%)))) - (setf ix kx) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - temp))) - (setf ix (f2cl-lib:int-add ix incx)))))) - (setf jy (f2cl-lib:int-add jy incy)))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zgerc fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zgeru BLAS} -\pagehead{zgeru}{zgeru} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero (complex 0.0 0.0))) - (declare (type (complex double-float) zero)) - (defun zgeru (m n alpha x incx y incy a lda) - (declare (type (array (complex double-float) (*)) a y x) - (type (complex double-float) alpha) - (type fixnum lda incy incx n m)) - (f2cl-lib:with-multi-array-data - ((x (complex double-float) x-%data% x-%offset%) - (y (complex double-float) y-%data% y-%offset%) - (a (complex double-float) a-%data% a-%offset%)) - (prog ((i 0) (info 0) (ix 0) (j 0) (jy 0) (kx 0) (temp #C(0.0 0.0))) - (declare (type fixnum i info ix j jy kx) - (type (complex double-float) temp)) - (setf info 0) - (cond - ((< m 0) - (setf info 1)) - ((< n 0) - (setf info 2)) - ((= incx 0) - (setf info 5)) - ((= incy 0) - (setf info 7)) - ((< lda (max (the fixnum 1) (the fixnum m))) - (setf info 9))) - (cond - ((/= info 0) - (xerbla "ZGERU " info) - (go end_label))) - (if (or (= m 0) (= n 0) (= alpha zero)) (go end_label)) - (cond - ((> incy 0) - (setf jy 1)) - (t - (setf jy - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incy))))) - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref y (jy) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%) - temp))))))) - (setf jy (f2cl-lib:int-add jy incy))))) - (t - (cond - ((> incx 0) - (setf kx 1)) - (t - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul - (f2cl-lib:int-sub m 1) - incx))))) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref y (jy) ((1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%))) - (setf ix kx) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - temp))) - (setf ix (f2cl-lib:int-add ix incx)))))) - (setf jy (f2cl-lib:int-add jy incy)))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zgeru fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zhbmv BLAS} -\pagehead{zhbmv}{zhbmv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) - (declare (type (complex double-float) one) (type (complex double-float) zero)) - (defun zhbmv (uplo n k alpha a lda x incx beta y incy) - (declare (type (array (complex double-float) (*)) y x a) - (type (complex double-float) beta alpha) - (type fixnum incy incx lda k n) - (type (simple-array character (*)) uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (a (complex double-float) a-%data% a-%offset%) - (x (complex double-float) x-%data% x-%offset%) - (y (complex double-float) y-%data% y-%offset%)) - (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (kplus1 0) (kx 0) - (ky 0) (l 0) (temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0))) - (declare (type fixnum i info ix iy j jx jy kplus1 kx ky l) - (type (complex double-float) temp1 temp2)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((< n 0) - (setf info 2)) - ((< k 0) - (setf info 3)) - ((< lda (f2cl-lib:int-add k 1)) - (setf info 6)) - ((= incx 0) - (setf info 8)) - ((= incy 0) - (setf info 11))) - (cond - ((/= info 0) - (xerbla "ZHBMV " info) - (go end_label))) - (if (or (= n 0) (and (= alpha zero) (= beta one))) (go end_label)) - (cond - ((> incx 0) - (setf kx 1)) - (t - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx))))) - (cond - ((> incy 0) - (setf ky 1)) - (t - (setf ky - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incy))))) - (cond - ((/= beta one) - (cond - ((= incy 1) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - zero)))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%)))))))) - (t - (setf iy ky) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - zero) - (setf iy (f2cl-lib:int-add iy incy))))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%))) - (setf iy (f2cl-lib:int-add iy incy)))))))))) - (if (= alpha zero) (go end_label)) - (cond - ((lsame uplo "U") - (setf kplus1 (f2cl-lib:int-add k 1)) - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf l (f2cl-lib:int-sub kplus1 j)) - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k)))) - (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (* temp1 - (coerce (realpart - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float)) - (* alpha temp2)))))) - (t - (setf jx kx) - (setf jy ky) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf ix kx) - (setf iy ky) - (setf l (f2cl-lib:int-sub kplus1 j)) - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k)))) - (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* temp1 - (coerce (realpart - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float)) - (* alpha temp2))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy)) - (cond - ((> j k) - (setf kx (f2cl-lib:int-add kx incx)) - (setf ky (f2cl-lib:int-add ky incy))))))))) - (t - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (* temp1 - (coerce (realpart - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float)))) - (setf l (f2cl-lib:int-sub 1 j)) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k)))) - nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (* alpha temp2)))))) - (t - (setf jx kx) - (setf jy ky) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* temp1 - (coerce (realpart - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float)))) - (setf l (f2cl-lib:int-sub 1 j)) - (setf ix jx) - (setf iy jy) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k)))) - nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)) - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* alpha temp2))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy)))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zhbmv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zhemm BLAS} -\pagehead{zhemm}{zhemm} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) - (declare (type (complex double-float) one) (type (complex double-float) zero)) - (defun zhemm (side uplo m n alpha a lda b ldb$ beta c ldc) - (declare (type (array (complex double-float) (*)) c b a) - (type (complex double-float) beta alpha) - (type fixnum ldc ldb$ lda n m) - (type (simple-array character (*)) uplo side)) - (f2cl-lib:with-multi-array-data - ((side character side-%data% side-%offset%) - (uplo character uplo-%data% uplo-%offset%) - (a (complex double-float) a-%data% a-%offset%) - (b (complex double-float) b-%data% b-%offset%) - (c (complex double-float) c-%data% c-%offset%)) - (prog ((temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0)) (i 0) (info 0) (j 0) (k 0) - (nrowa 0) (upper nil)) - (declare (type (complex double-float) temp1 temp2) - (type fixnum i info j k nrowa) - (type (member t nil) upper)) - (cond - ((lsame side "L") - (setf nrowa m)) - (t - (setf nrowa n))) - (setf upper (lsame uplo "U")) - (setf info 0) - (cond - ((and (not (lsame side "L")) (not (lsame side "R"))) - (setf info 1)) - ((and (not upper) (not (lsame uplo "L"))) - (setf info 2)) - ((< m 0) - (setf info 3)) - ((< n 0) - (setf info 4)) - ((< lda (max (the fixnum 1) (the fixnum nrowa))) - (setf info 7)) - ((< ldb$ (max (the fixnum 1) (the fixnum m))) - (setf info 9)) - ((< ldc (max (the fixnum 1) (the fixnum m))) - (setf info 12))) - (cond - ((/= info 0) - (xerbla "ZHEMM " info) - (go end_label))) - (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one))) - (go end_label)) - (cond - ((= alpha zero) - (cond - ((= beta zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))))) - (go end_label))) - (cond - ((lsame side "L") - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))) - (setf temp2 zero) - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add i - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (k j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (k j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%))))))) - (cond - ((= beta zero) - (setf - (f2cl-lib:fref c-%data% (i j) ((1 ldc) (1 *)) - c-%offset%) - (+ - (* temp1 - (coerce (realpart - (f2cl-lib:fref a-%data% (i i) ((1 lda) (1 *)) - a-%offset%)) - 'double-float)) - (* alpha temp2)))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)) - (* temp1 - (coerce (realpart - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%)) 'double-float)) - - (* alpha temp2)))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i m (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))) - (setf temp2 zero) - (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) - (f2cl-lib:int-add k 1)) - ((> k m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (k j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (k j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%))))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* temp1 - (coerce (realpart - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%)) 'double-float)) - (* alpha temp2)))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)) - (* temp1 - (coerce (realpart - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%)) 'double-float)) - (* alpha temp2)))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float))) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp1 - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%)))))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)) - (* temp1 - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%)))))))) - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - nil) - (tagbody - (cond - (upper - (setf temp1 - (* alpha - (f2cl-lib:fref a-%data% - (k j) - ((1 lda) (1 *)) - a-%offset%)))) - (t - (setf temp1 - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (j k) - ((1 lda) (1 *)) - a-%offset%)))))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp1 - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))) - (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) (f2cl-lib:int-add k 1)) - ((> k n) nil) - (tagbody - (cond - (upper - (setf temp1 - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (j k) - ((1 lda) (1 *)) - a-%offset%))))) - (t - (setf temp1 - (* alpha - (f2cl-lib:fref a-%data% - (k j) - ((1 lda) (1 *)) - a-%offset%))))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp1 - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zhemm fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zhemv BLAS} -\pagehead{zhemv}{zhemv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) - (declare (type (complex double-float) one) (type (complex double-float) zero)) - (defun zhemv (uplo n alpha a lda x incx beta y incy) - (declare (type (array (complex double-float) (*)) y x a) - (type (complex double-float) beta alpha) - (type fixnum incy incx lda n) - (type (simple-array character (*)) uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (a (complex double-float) a-%data% a-%offset%) - (x (complex double-float) x-%data% x-%offset%) - (y (complex double-float) y-%data% y-%offset%)) - (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (kx 0) (ky 0) - (temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0))) - (declare (type fixnum i info ix iy j jx jy kx ky) - (type (complex double-float) temp1 temp2)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((< n 0) - (setf info 2)) - ((< lda (max (the fixnum 1) (the fixnum n))) - (setf info 5)) - ((= incx 0) - (setf info 7)) - ((= incy 0) - (setf info 10))) - (cond - ((/= info 0) - (xerbla "ZHEMV " info) - (go end_label))) - (if (or (= n 0) (and (= alpha zero) (= beta one))) (go end_label)) - (cond - ((> incx 0) - (setf kx 1)) - (t - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx))))) - (cond - ((> incy 0) - (setf ky 1)) - (t - (setf ky - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incy))))) - (cond - ((/= beta one) - (cond - ((= incy 1) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - zero)))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%)))))))) - (t - (setf iy ky) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - zero) - (setf iy (f2cl-lib:int-add iy incy))))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%))) - (setf iy (f2cl-lib:int-add iy incy)))))))))) - (if (= alpha zero) (go end_label)) - (cond - ((lsame uplo "U") - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) - (setf temp2 zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (* temp1 - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float)) - (* alpha temp2)))))) - (t - (setf jx kx) - (setf jy ky) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf ix kx) - (setf iy ky) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* temp1 - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float)) - (* alpha temp2))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy))))))) - (t - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (* temp1 - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float)))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (* alpha temp2)))))) - (t - (setf jx kx) - (setf jy ky) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* temp1 - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float)))) - (setf ix jx) - (setf iy jy) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)) - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* alpha temp2))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy)))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zhemv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zher2k BLAS} -\pagehead{zher2k}{zher2k} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one 1.0) (zero (complex 0.0 0.0))) - (declare (type (double-float 1.0 1.0) one) (type (complex double-float) zero)) - (defun zher2k (uplo trans n k alpha a lda b ldb$ beta c ldc) - (declare (type (double-float) beta) - (type (array (complex double-float) (*)) c b a) - (type (complex double-float) alpha) - (type fixnum ldc ldb$ lda k n) - (type (simple-array character (*)) trans uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (trans character trans-%data% trans-%offset%) - (a (complex double-float) a-%data% a-%offset%) - (b (complex double-float) b-%data% b-%offset%) - (c (complex double-float) c-%data% c-%offset%)) - (prog ((temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0)) (i 0) (info 0) (j 0) (l 0) - (nrowa 0) (upper nil)) - (declare (type (complex double-float) temp1 temp2) - (type fixnum i info j l nrowa) - (type (member t nil) upper)) - (cond - ((lsame trans "N") - (setf nrowa n)) - (t - (setf nrowa k))) - (setf upper (lsame uplo "U")) - (setf info 0) - (cond - ((and (not upper) (not (lsame uplo "L"))) - (setf info 1)) - ((and (not (lsame trans "N")) (not (lsame trans "C"))) - (setf info 2)) - ((< n 0) - (setf info 3)) - ((< k 0) - (setf info 4)) - ((< lda (max (the fixnum 1) (the fixnum nrowa))) - (setf info 7)) - ((< ldb$ - (max (the fixnum 1) (the fixnum nrowa))) - (setf info 9)) - ((< ldc (max (the fixnum 1) (the fixnum n))) - (setf info 12))) - (cond - ((/= info 0) - (xerbla "ZHER2K" info) - (go end_label))) - (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) - (go end_label)) - (cond - ((= alpha zero) - (cond - (upper - (cond - ((= beta (coerce (realpart zero) 'double-float)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))) - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (* beta - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%)) 'double-float)) - '(complex double-float)))))))) - (t - (cond - ((= beta (coerce (realpart zero) 'double-float)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (* beta - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%)) 'double-float)) - '(complex double-float))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))))))) - (go end_label))) - (cond - ((lsame trans "N") - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((= beta (coerce (realpart zero) 'double-float)) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))) - ((/= beta one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))) - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (* beta - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%)) 'double-float)) - '(complex double-float)))) - (t - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%)) 'double-float) - '(complex double-float))))) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) - (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref b-%data% - (j l) - ((1 ldb$) (1 *)) - b-%offset%)))) - (setf temp2 - (coerce - (f2cl-lib:dconjg - (* alpha - (f2cl-lib:fref a-%data% - (j l) - ((1 lda) (1 *)) - a-%offset%))) - '(complex double-float))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* - (f2cl-lib:fref a-%data% - (i l) - ((1 lda) (1 *)) - a-%offset%) - temp1) - (* - (f2cl-lib:fref b-%data% - (i l) - ((1 ldb$) (1 *)) - b-%offset%) - temp2))))) - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%)) 'double-float) - (coerce (realpart - (+ - (* - (f2cl-lib:fref a-%data% - (j l) - ((1 lda) (1 *)) - a-%offset%) - temp1) - (* - (f2cl-lib:fref b-%data% - (j l) - ((1 ldb$) (1 *)) - b-%offset%) - temp2))) 'double-float)) - '(complex double-float)))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((= beta (coerce (realpart zero) 'double-float)) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))) - ((/= beta one) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))) - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (* beta - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%))' double-float)) - '(complex double-float)))) - (t - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%)) 'double-float) - '(complex double-float))))) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) - (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref b-%data% - (j l) - ((1 ldb$) (1 *)) - b-%offset%)))) - (setf temp2 - (coerce - (f2cl-lib:dconjg - (* alpha - (f2cl-lib:fref a-%data% - (j l) - ((1 lda) (1 *)) - a-%offset%))) - '(complex double-float))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* - (f2cl-lib:fref a-%data% - (i l) - ((1 lda) (1 *)) - a-%offset%) - temp1) - (* - (f2cl-lib:fref b-%data% - (i l) - ((1 ldb$) (1 *)) - b-%offset%) - temp2))))) - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%)) 'double-float) - (coerce (realpart - (+ - (* - (f2cl-lib:fref a-%data% - (j l) - ((1 lda) (1 *)) - a-%offset%) - temp1) - (* - (f2cl-lib:fref b-%data% - (j l) - ((1 ldb$) (1 *)) - b-%offset%) - temp2))) 'double-float)) - '(complex double-float)))))))))))) - (t - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf temp1 zero) - (setf temp2 zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp1 - (+ temp1 - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref b-%data% - (l j) - ((1 ldb$) (1 *)) - b-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:dconjg - (f2cl-lib:fref b-%data% - (l i) - ((1 ldb$) (1 *)) - b-%offset%)) - (f2cl-lib:fref a-%data% - (l j) - ((1 lda) (1 *)) - a-%offset%)))))) - (cond - ((= i j) - (cond - ((= beta (coerce (realpart zero) 'double-float)) - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (coerce (realpart - (+ (* alpha temp1) - (* (f2cl-lib:dconjg alpha) temp2))) - 'double-float) - '(complex double-float)))) - (t - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (+ - (* beta - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%)) - 'double-float)) - (coerce (realpart - (+ (* alpha temp1) - (* (f2cl-lib:dconjg alpha) temp2))) - 'double-float)) - '(complex double-float)))))) - (t - (cond - ((= beta (coerce (realpart zero) 'double-float)) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp1) - (* (f2cl-lib:dconjg alpha) temp2)))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)) - (* alpha temp1) - (* (f2cl-lib:dconjg alpha) temp2)))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf temp1 zero) - (setf temp2 zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp1 - (+ temp1 - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref b-%data% - (l j) - ((1 ldb$) (1 *)) - b-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:dconjg - (f2cl-lib:fref b-%data% - (l i) - ((1 ldb$) (1 *)) - b-%offset%)) - (f2cl-lib:fref a-%data% - (l j) - ((1 lda) (1 *)) - a-%offset%)))))) - (cond - ((= i j) - (cond - ((= beta (coerce (realpart zero) 'double-float)) - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (coerce (realpart - (+ (* alpha temp1) - (* (f2cl-lib:dconjg alpha) temp2))) - 'double-float) - '(complex double-float)))) - (t - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (+ - (* beta - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%)) - 'double-float)) - (coerce (realpart - (+ (* alpha temp1) - (* (f2cl-lib:dconjg alpha) temp2))) - 'double-float)) - '(complex double-float)))))) - (t - (cond - ((= beta (coerce (realpart zero) 'double-float)) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp1) - (* (f2cl-lib:dconjg alpha) temp2)))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)) - (* alpha temp1) - (* (f2cl-lib:dconjg alpha) temp2))))))))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zher2k - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum (double-float) - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zher2 BLAS} -\pagehead{zher2}{zher2} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero (complex 0.0 0.0))) - (declare (type (complex double-float) zero)) - (defun zher2 (uplo n alpha x incx y incy a lda) - (declare (type (array (complex double-float) (*)) a y x) - (type (complex double-float) alpha) - (type fixnum lda incy incx n) - (type (simple-array character (*)) uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (x (complex double-float) x-%data% x-%offset%) - (y (complex double-float) y-%data% y-%offset%) - (a (complex double-float) a-%data% a-%offset%)) - (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (kx 0) (ky 0) - (temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0))) - (declare (type fixnum i info ix iy j jx jy kx ky) - (type (complex double-float) temp1 temp2)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((< n 0) - (setf info 2)) - ((= incx 0) - (setf info 5)) - ((= incy 0) - (setf info 7)) - ((< lda (max (the fixnum 1) (the fixnum n))) - (setf info 9))) - (cond - ((/= info 0) - (xerbla "ZHER2 " info) - (go end_label))) - (if (or (= n 0) (= alpha zero)) (go end_label)) - (cond - ((or (/= incx 1) (/= incy 1)) - (cond - ((> incx 0) - (setf kx 1)) - (t - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))))) - (cond - ((> incy 0) - (setf ky 1)) - (t - (setf ky - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incy))))) - (setf jx kx) - (setf jy ky))) - (cond - ((lsame uplo "U") - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) - (/= (f2cl-lib:fref y (j) ((1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref y-%data% - (j) - ((1 *)) - y-%offset%)))) - (setf temp2 - (coerce - (f2cl-lib:dconjg - (* alpha - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%))) - '(complex double-float))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%) - temp2))))) - (setf (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float) - (coerce (realpart - (+ - (* - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (j) - ((1 *)) - y-%offset%) - temp2))) 'double-float)) - '(complex double-float)))) - (t - (setf (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float) - '(complex double-float)))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref y-%data% - (jy) - ((1 *)) - y-%offset%)))) - (setf temp2 - (coerce - (f2cl-lib:dconjg - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - '(complex double-float))) - (setf ix kx) - (setf iy ky) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%) - temp2))) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))) - (setf (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float) - (coerce (realpart - (+ - (* - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (jy) - ((1 *)) - y-%offset%) - temp2))) 'double-float)) - '(complex double-float)))) - (t - (setf (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float) - '(complex double-float))))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy))))))) - (t - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) - (/= (f2cl-lib:fref y (j) ((1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref y-%data% - (j) - ((1 *)) - y-%offset%)))) - (setf temp2 - (coerce - (f2cl-lib:dconjg - (* alpha - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%))) - '(complex double-float))) - (setf (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float) - (coerce (realpart - (+ - (* - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (j) - ((1 *)) - y-%offset%) - temp2))) 'double-float)) - '(complex double-float))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%) - temp2)))))) - (t - (setf (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float) - '(complex double-float)))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref y-%data% - (jy) - ((1 *)) - y-%offset%)))) - (setf temp2 - (coerce - (f2cl-lib:dconjg - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - '(complex double-float))) - (setf (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float) - (coerce (realpart - (+ - (* - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (jy) - ((1 *)) - y-%offset%) - temp2))) 'double-float)) - '(complex double-float))) - (setf ix jx) - (setf iy jy) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)) - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%) - temp2)))))) - (t - (setf (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float) - '(complex double-float))))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy)))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zher2 fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zherk BLAS} -\pagehead{zherk}{zherk} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one 1.0) (zero 0.0)) - (declare (type (double-float 1.0 1.0) one) - (type (double-float 0.0 0.0) zero)) - (defun zherk (uplo trans n k alpha a lda beta c ldc) - (declare (type (array (complex double-float) (*)) c a) - (type (double-float) beta alpha) - (type fixnum ldc lda k n) - (type (simple-array character (*)) trans uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (trans character trans-%data% trans-%offset%) - (a (complex double-float) a-%data% a-%offset%) - (c (complex double-float) c-%data% c-%offset%)) - (prog ((temp #C(0.0 0.0)) (rtemp 0.0) (i 0) (info 0) (j 0) (l 0) - (nrowa 0) (upper nil)) - (declare (type (complex double-float) temp) - (type (double-float) rtemp) - (type fixnum i info j l nrowa) - (type (member t nil) upper)) - (cond - ((lsame trans "N") - (setf nrowa n)) - (t - (setf nrowa k))) - (setf upper (lsame uplo "U")) - (setf info 0) - (cond - ((and (not upper) (not (lsame uplo "L"))) - (setf info 1)) - ((and (not (lsame trans "N")) (not (lsame trans "C"))) - (setf info 2)) - ((< n 0) - (setf info 3)) - ((< k 0) - (setf info 4)) - ((< lda (max (the fixnum 1) (the fixnum nrowa))) - (setf info 7)) - ((< ldc (max (the fixnum 1) (the fixnum n))) - (setf info 10))) - (cond - ((/= info 0) - (xerbla "ZHERK " info) - (go end_label))) - (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) - (go end_label)) - (cond - ((= alpha zero) - (cond - (upper - (cond - ((= beta zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce zero '(complex double-float)))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))) - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (* beta - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%)) 'double-float)) - '(complex double-float)))))))) - (t - (cond - ((= beta zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce zero '(complex double-float)))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (* beta - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%)) 'double-float)) - '(complex double-float))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))))))) - (go end_label))) - (cond - ((lsame trans "N") - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce zero '(complex double-float)))))) - ((/= beta one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))) - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (* beta - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%)) 'double-float)) - '(complex double-float)))) - (t - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%)) 'double-float) - '(complex double-float))))) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) - (coerce (complex zero) '(complex double-float))) - (setf temp - (coerce - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (j l) - ((1 lda) (1 *)) - a-%offset%))) - '(complex double-float))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i l) - ((1 lda) (1 *)) - a-%offset%)))))) - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%)) 'double-float) - (coerce (realpart - (* temp - (f2cl-lib:fref a-%data% - (i l) - ((1 lda) (1 *)) - a-%offset%))) - 'double-float)) - '(complex double-float)))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((= beta zero) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce zero '(complex double-float)))))) - ((/= beta one) - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (* beta - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%)) 'double-float)) - '(complex double-float))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)))))) - (t - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%)) 'double-float) - '(complex double-float))))) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) - (coerce (complex zero) '(complex double-float))) - (setf temp - (coerce - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (j l) - ((1 lda) (1 *)) - a-%offset%))) - '(complex double-float))) - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%)) 'double-float) - (coerce (realpart - (* temp - (f2cl-lib:fref a-%data% - (j l) - ((1 lda) (1 *)) - a-%offset%))) - 'double-float)) - '(complex double-float))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i l) - ((1 lda) (1 *)) - a-%offset%))))))))))))))) - (t - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf temp (coerce zero '(complex double-float))) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref a-%data% - (l j) - ((1 lda) (1 *)) - a-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* alpha temp))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)))))))) - (setf rtemp zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf rtemp - (coerce - (realpart - (+ rtemp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (l j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref a-%data% - (l j) - ((1 lda) (1 *)) - a-%offset%)))) - 'double-float)))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce (* alpha rtemp) '(complex double-float)))) - (t - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (+ (* alpha rtemp) - (* beta - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%)) - 'double-float))) - '(complex double-float)))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf rtemp zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf rtemp - (coerce - (realpart - (+ rtemp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (l j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref a-%data% - (l j) - ((1 lda) (1 *)) - a-%offset%)))) - 'double-float)))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce (* alpha rtemp) '(complex double-float)))) - (t - (setf (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%) - (coerce - (+ (* alpha rtemp) - (* beta - (coerce (realpart - (f2cl-lib:fref c-%data% - (j j) - ((1 ldc) (1 *)) - c-%offset%)) - 'double-float))) - '(complex double-float))))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf temp (coerce zero '(complex double-float))) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref a-%data% - (l j) - ((1 lda) (1 *)) - a-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* alpha temp))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)))))))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zherk fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - (double-float) (array (complex double-float) (*)) - fixnum (double-float) - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zher BLAS} -\pagehead{zher}{zher} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero (complex 0.0 0.0))) - (declare (type (complex double-float) zero)) - (defun zher (uplo n alpha x incx a lda) - (declare (type (array (complex double-float) (*)) a x) - (type (double-float) alpha) - (type fixnum lda incx n) - (type (simple-array character (*)) uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (x (complex double-float) x-%data% x-%offset%) - (a (complex double-float) a-%data% a-%offset%)) - (prog ((i 0) (info 0) (ix 0) (j 0) (jx 0) (kx 0) (temp #C(0.0 0.0))) - (declare (type fixnum i info ix j jx kx) - (type (complex double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((< n 0) - (setf info 2)) - ((= incx 0) - (setf info 5)) - ((< lda (max (the fixnum 1) (the fixnum n))) - (setf info 7))) - (cond - ((/= info 0) - (xerbla "ZHER " info) - (go end_label))) - (if (or (= n 0) (= alpha (coerce (realpart zero) 'double-float))) - (go end_label)) - (cond - ((<= incx 0) - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx)))) - ((/= incx 1) - (setf kx 1))) - (cond - ((lsame uplo "U") - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (coerce - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%))) - '(complex double-float))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - temp))))) - (setf (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float) - (coerce (realpart - (* - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - temp)) 'double-float)) - '(complex double-float)))) - (t - (setf (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float) - '(complex double-float)))))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (coerce - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - '(complex double-float))) - (setf ix kx) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - temp))) - (setf ix (f2cl-lib:int-add ix incx)))) - (setf (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float) - (coerce (realpart - (* - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - temp)) 'double-float)) - '(complex double-float)))) - (t - (setf (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float) - '(complex double-float))))) - (setf jx (f2cl-lib:int-add jx incx))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (coerce - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%))) - '(complex double-float))) - (setf (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float) - (coerce (realpart - (* temp - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%))) 'double-float)) - '(complex double-float))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - temp)))))) - (t - (setf (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float) - '(complex double-float)))))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (coerce - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - '(complex double-float))) - (setf (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float) - (coerce (realpart - (* temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) 'double-float)) - '(complex double-float))) - (setf ix jx) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (+ - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (* - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - temp)))))) - (t - (setf (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)) 'double-float) - '(complex double-float))))) - (setf jx (f2cl-lib:int-add jx incx)))))))) - end_label - (return (values nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zher fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum (double-float) - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zhpmv BLAS} -\pagehead{zhpmv}{zhpmv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) - (declare (type (complex double-float) one) (type (complex double-float) zero)) - (defun zhpmv (uplo n alpha ap x incx beta y incy) - (declare (type (array (complex double-float) (*)) y x ap) - (type (complex double-float) beta alpha) - (type fixnum incy incx n) - (type (simple-array character (*)) uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (ap (complex double-float) ap-%data% ap-%offset%) - (x (complex double-float) x-%data% x-%offset%) - (y (complex double-float) y-%data% y-%offset%)) - (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (k 0) (kk 0) - (kx 0) (ky 0) (temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0))) - (declare (type fixnum i info ix iy j jx jy k kk kx ky) - (type (complex double-float) temp1 temp2)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((< n 0) - (setf info 2)) - ((= incx 0) - (setf info 6)) - ((= incy 0) - (setf info 9))) - (cond - ((/= info 0) - (xerbla "ZHPMV " info) - (go end_label))) - (if (or (= n 0) (and (= alpha zero) (= beta one))) (go end_label)) - (cond - ((> incx 0) - (setf kx 1)) - (t - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx))))) - (cond - ((> incy 0) - (setf ky 1)) - (t - (setf ky - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incy))))) - (cond - ((/= beta one) - (cond - ((= incy 1) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - zero)))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%)))))))) - (t - (setf iy ky) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - zero) - (setf iy (f2cl-lib:int-add iy incy))))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* beta - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%))) - (setf iy (f2cl-lib:int-add iy incy)))))))))) - (if (= alpha zero) (go end_label)) - (setf kk 1) - (cond - ((lsame uplo "U") - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf k kk) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))) - (setf k (f2cl-lib:int-add k 1)))) - (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (* temp1 - (coerce (realpart - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%)) 'double-float)) - (* alpha temp2))) - (setf kk (f2cl-lib:int-add kk j))))) - (t - (setf jx kx) - (setf jy ky) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf ix kx) - (setf iy ky) - (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - j - (f2cl-lib:int-sub 2))) - nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* temp1 - (coerce (realpart - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%)) 'double-float)) - (* alpha temp2))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy)) - (setf kk (f2cl-lib:int-add kk j))))))) - (t - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (* temp1 - (coerce (realpart - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)) 'double-float)))) - (setf k (f2cl-lib:int-add kk 1)) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))) - (setf k (f2cl-lib:int-add k 1)))) - (setf (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (j) ((1 *)) y-%offset%) - (* alpha temp2))) - (setf kk - (f2cl-lib:int-add kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1)))))) - (t - (setf jx kx) - (setf jy ky) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%))) - (setf temp2 zero) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* temp1 - (coerce (realpart - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)) 'double-float)))) - (setf ix jx) - (setf iy jy) - (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) - (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - n - (f2cl-lib:int-sub j))) - nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)) - (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (+ - (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%) - (* temp1 - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))))) - (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%) - (* alpha temp2))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy)) - (setf kk - (f2cl-lib:int-add kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zhpmv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum - ((complex double-float)) - (array (complex double-float) (*)) - (array (complex double-float) (*)) - fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zhpr2 BLAS} -\pagehead{zhpr2}{zhpr2} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero (complex 0.0 0.0))) - (declare (type (complex double-float) zero)) - (defun zhpr2 (uplo n alpha x incx y incy ap) - (declare (type (array (complex double-float) (*)) ap y x) - (type (complex double-float) alpha) - (type fixnum incy incx n) - (type (simple-array character (*)) uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (x (complex double-float) x-%data% x-%offset%) - (y (complex double-float) y-%data% y-%offset%) - (ap (complex double-float) ap-%data% ap-%offset%)) - (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (k 0) (kk 0) - (kx 0) (ky 0) (temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0))) - (declare (type fixnum i info ix iy j jx jy k kk kx ky) - (type (complex double-float) temp1 temp2)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((< n 0) - (setf info 2)) - ((= incx 0) - (setf info 5)) - ((= incy 0) - (setf info 7))) - (cond - ((/= info 0) - (xerbla "ZHPR2 " info) - (go end_label))) - (if (or (= n 0) (= alpha zero)) (go end_label)) - (cond - ((or (/= incx 1) (/= incy 1)) - (cond - ((> incx 0) - (setf kx 1)) - (t - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))))) - (cond - ((> incy 0) - (setf ky 1)) - (t - (setf ky - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incy))))) - (setf jx kx) - (setf jy ky))) - (setf kk 1) - (cond - ((lsame uplo "U") - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) - (/= (f2cl-lib:fref y (j) ((1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref y-%data% - (j) - ((1 *)) - y-%offset%)))) - (setf temp2 - (coerce - (f2cl-lib:dconjg - (* alpha - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%))) - '(complex double-float))) - (setf k kk) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (+ - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (* - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%) - temp2))) - (setf k (f2cl-lib:int-add k 1)))) - (setf (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%)) 'double-float) - (coerce (realpart - (+ - (* - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (j) - ((1 *)) - y-%offset%) - temp2))) 'double-float)) - '(complex double-float)))) - (t - (setf (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%)) 'double-float) - '(complex double-float))))) - (setf kk (f2cl-lib:int-add kk j))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref y-%data% - (jy) - ((1 *)) - y-%offset%)))) - (setf temp2 - (coerce - (f2cl-lib:dconjg - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - '(complex double-float))) - (setf ix kx) - (setf iy ky) - (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - j - (f2cl-lib:int-sub 2))) - nil) - (tagbody - (setf (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (+ - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (* - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%) - temp2))) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))) - (setf (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%)) 'double-float) - (coerce (realpart - (+ - (* - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (jy) - ((1 *)) - y-%offset%) - temp2))) 'double-float)) - '(complex double-float)))) - (t - (setf (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%)) 'double-float) - '(complex double-float))))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy)) - (setf kk (f2cl-lib:int-add kk j))))))) - (t - (cond - ((and (= incx 1) (= incy 1)) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref x (j) ((1 *))) zero) - (/= (f2cl-lib:fref y (j) ((1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref y-%data% - (j) - ((1 *)) - y-%offset%)))) - (setf temp2 - (coerce - (f2cl-lib:dconjg - (* alpha - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%))) - '(complex double-float))) - (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)) 'double-float) - (coerce (realpart - (+ - (* - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (j) - ((1 *)) - y-%offset%) - temp2))) 'double-float)) - '(complex double-float))) - (setf k (f2cl-lib:int-add kk 1)) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (+ - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (* - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (i) - ((1 *)) - y-%offset%) - temp2))) - (setf k (f2cl-lib:int-add k 1))))) - (t - (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)) 'double-float) - '(complex double-float))))) - (setf kk - (f2cl-lib:int-add - (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) - 1))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (/= (f2cl-lib:fref y (jy) ((1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref y-%data% - (jy) - ((1 *)) - y-%offset%)))) - (setf temp2 - (coerce - (f2cl-lib:dconjg - (* alpha - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - '(complex double-float))) - (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)) 'double-float) - (coerce (realpart - (+ - (* - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (jy) - ((1 *)) - y-%offset%) - temp2))) 'double-float)) - '(complex double-float))) - (setf ix jx) - (setf iy jy) - (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) - (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - n - (f2cl-lib:int-sub j))) - nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)) - (setf (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (+ - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (* - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - temp1) - (* - (f2cl-lib:fref y-%data% - (iy) - ((1 *)) - y-%offset%) - temp2)))))) - (t - (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)) 'double-float) - '(complex double-float))))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf jy (f2cl-lib:int-add jy incy)) - (setf kk - (f2cl-lib:int-add - (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) - 1)))))))) - end_label - (return (values nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zhpr2 fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*))) - :return-values '(nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zhpr BLAS} -\pagehead{zhpr}{zhpr} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero (complex 0.0 0.0))) - (declare (type (complex double-float) zero)) - (defun zhpr (uplo n alpha x incx ap) - (declare (type (array (complex double-float) (*)) ap x) - (type (double-float) alpha) - (type fixnum incx n) - (type (simple-array character (*)) uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (x (complex double-float) x-%data% x-%offset%) - (ap (complex double-float) ap-%data% ap-%offset%)) - (prog ((i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0) (kk 0) (kx 0) - (temp #C(0.0 0.0))) - (declare (type fixnum i info ix j jx k kk kx) - (type (complex double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((< n 0) - (setf info 2)) - ((= incx 0) - (setf info 5))) - (cond - ((/= info 0) - (xerbla "ZHPR " info) - (go end_label))) - (if (or (= n 0) (= alpha (coerce (realpart zero) 'double-float))) - (go end_label)) - (cond - ((<= incx 0) - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx)))) - ((/= incx 1) - (setf kx 1))) - (setf kk 1) - (cond - ((lsame uplo "U") - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (coerce - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%))) - '(complex double-float))) - (setf k kk) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (setf (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (+ - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (* - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - temp))) - (setf k (f2cl-lib:int-add k 1)))) - (setf (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%)) 'double-float) - (coerce (realpart - (* - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - temp)) 'double-float)) - '(complex double-float)))) - (t - (setf (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%)) 'double-float) - '(complex double-float))))) - (setf kk (f2cl-lib:int-add kk j))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (coerce - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - '(complex double-float))) - (setf ix kx) - (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - j - (f2cl-lib:int-sub 2))) - nil) - (tagbody - (setf (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (+ - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (* - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - temp))) - (setf ix (f2cl-lib:int-add ix incx)))) - (setf (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%)) 'double-float) - (coerce (realpart - (* - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - temp)) 'double-float)) - '(complex double-float)))) - (t - (setf (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%)) 'double-float) - '(complex double-float))))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf kk (f2cl-lib:int-add kk j))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (coerce - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%))) - '(complex double-float))) - (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)) 'double-float) - (coerce (realpart - (* temp - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%))) 'double-float)) - '(complex double-float))) - (setf k (f2cl-lib:int-add kk 1)) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (+ - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (* - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - temp))) - (setf k (f2cl-lib:int-add k 1))))) - (t - (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)) 'double-float) - '(complex double-float))))) - (setf kk - (f2cl-lib:int-add - (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) - 1))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (coerce - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) - '(complex double-float))) - (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) - (coerce - (+ - (coerce (realpart - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)) 'double-float) - (coerce (realpart - (* temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%))) 'double-float)) - '(complex double-float))) - (setf ix jx) - (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) - (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - n - (f2cl-lib:int-sub j))) - nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (+ - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (* - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - temp)))))) - (t - (setf (f2cl-lib:fref ap-%data% (kk) ((1 *)) ap-%offset%) - (coerce - (coerce (realpart - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)) 'double-float) - '(complex double-float))))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf kk - (f2cl-lib:int-add - (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j) - 1)))))))) - end_label - (return (values nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zhpr fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum (double-float) - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*))) - :return-values '(nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::ilaenv +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum +; (simple-array character (*)) +; (simple-array character (*)) +; fixnum fixnum +; fixnum +; fixnum) +; :return-values '(nil nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::ieeeck))));; @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{zlange LAPACK} -\pagehead{zlange}{zlange} +%\pagehead{zlange}{zlange} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -55634,23 +60095,23 @@ Return values are: (setf zlange value) (return (values zlange nil nil nil nil nil nil)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zlange - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - fixnum fixnum - (array (complex double-float) (*)) - fixnum (array double-float (*))) - :return-values '(nil nil nil nil nil nil) - :calls '(fortran-to-lisp::lsame fortran-to-lisp::zlassq)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zlange +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '((simple-array character (1)) +; fixnum fixnum +; (array (complex double-float) (*)) +; fixnum (array double-float (*))) +; :return-values '(nil nil nil nil nil nil) +; :calls '(fortran-to-lisp::lsame fortran-to-lisp::zlassq)))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{zlassq LAPACK} -\pagehead{zlassq}{zlassq} +%\pagehead{zlassq}{zlassq} %\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} <>= @@ -55701,6098 +60162,30 @@ Return values are: (setf sumsq (+ sumsq (expt (/ temp1 scale) 2))))))))))) (return (values nil nil nil scale sumsq)))))) -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zlassq - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum - (array (complex double-float) (*)) - fixnum (double-float) - (double-float)) - :return-values '(nil nil nil fortran-to-lisp::scale - fortran-to-lisp::sumsq) - :calls 'nil))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zrotg BLAS} -\pagehead{zrotg}{zrotg} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - - -(Complex Double-Float). Computes plane rotation. -Arguments are: -\begin{itemize} -\item da - (complex double-float) -\item db - (complex double-float) -\item c - double-float -\item s - (complex double-float) -\end{itemize} -Returns multiple values where: -\begin{itemize} -\item 1 da - ca -\item 2 db - nil -\item 3 c - c -\item 4 s - s -\end{itemize} - -<>= -(defun zrotg (ca cb c s) - (declare (type (double-float) c) (type (complex double-float) s cb ca)) - (prog ((alpha #C(0.0 0.0)) (norm 0.0) (scale 0.0)) - (declare (type (double-float) scale norm) - (type (complex double-float) alpha)) - (if (/= (f2cl-lib:cdabs ca) 0.0) (go label10)) - (setf c 0.0) - (setf s (complex 1.0 0.0)) - (setf ca cb) - (go label20) - label10 - (setf scale - (coerce (+ (f2cl-lib:cdabs ca) (f2cl-lib:cdabs cb)) 'double-float)) - (setf norm - (* scale - (f2cl-lib:dsqrt - (+ (expt (f2cl-lib:cdabs (/ ca - (coerce (complex scale 0.0) '(complex double-float)))) 2) - (expt (f2cl-lib:cdabs (/ cb - (coerce (complex scale 0.0) '(complex double-float)))) - 2))))) - (setf alpha (/ ca (f2cl-lib:cdabs ca))) - (setf c (/ (f2cl-lib:cdabs ca) norm)) - (setf s (/ (* alpha (f2cl-lib:dconjg cb)) norm)) - (setf ca (* alpha norm)) - label20 - (return (values ca nil c s)))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zrotg fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(((complex double-float)) - ((complex double-float)) (double-float) - ((complex double-float))) - :return-values '(fortran-to-lisp::ca nil fortran-to-lisp::c - fortran-to-lisp::s) - :calls 'nil))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zscal BLAS} -\pagehead{zscal}{zscal} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(defun zscal (n za zx incx) - (declare (type (array (complex double-float) (*)) zx) - (type (complex double-float) za) - (type fixnum incx n)) - (f2cl-lib:with-multi-array-data - ((zx (complex double-float) zx-%data% zx-%offset%)) - (prog ((i 0) (ix 0)) - (declare (type fixnum ix i)) - (if (or (<= n 0) (<= incx 0)) (go end_label)) - (if (= incx 1) (go label20)) - (setf ix 1) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%) - (* za (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%))) - (setf ix (f2cl-lib:int-add ix incx)))) - (go end_label) - label20 - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%) - (* za (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%))))) - end_label - (return (values nil nil nil nil))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zscal fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil) - :calls 'nil))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zswap BLAS} -\pagehead{zswap}{zswap} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(defun zswap (n zx incx zy incy) - (declare (type (array (complex double-float) (*)) zy zx) - (type fixnum incy incx n)) - (f2cl-lib:with-multi-array-data - ((zx (complex double-float) zx-%data% zx-%offset%) - (zy (complex double-float) zy-%data% zy-%offset%)) - (prog ((i 0) (ix 0) (iy 0) (ztemp #C(0.0 0.0))) - (declare (type (complex double-float) ztemp) - (type fixnum iy ix i)) - (if (<= n 0) (go end_label)) - (if (and (= incx 1) (= incy 1)) (go label20)) - (setf ix 1) - (setf iy 1) - (if (< incx 0) - (setf ix - (f2cl-lib:int-add - (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incx) - 1))) - (if (< incy 0) - (setf iy - (f2cl-lib:int-add - (f2cl-lib:int-mul (f2cl-lib:int-sub 1 n) incy) - 1))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf ztemp (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%)) - (setf (f2cl-lib:fref zx-%data% (ix) ((1 *)) zx-%offset%) - (f2cl-lib:fref zy-%data% (iy) ((1 *)) zy-%offset%)) - (setf (f2cl-lib:fref zy-%data% (iy) ((1 *)) zy-%offset%) ztemp) - (setf ix (f2cl-lib:int-add ix incx)) - (setf iy (f2cl-lib:int-add iy incy)))) - (go end_label) - label20 - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf ztemp (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%)) - (setf (f2cl-lib:fref zx-%data% (i) ((1 *)) zx-%offset%) - (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%)) - (setf (f2cl-lib:fref zy-%data% (i) ((1 *)) zy-%offset%) ztemp))) - end_label - (return (values nil nil nil nil nil))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zswap fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '(fixnum - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil) - :calls 'nil))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zsymm BLAS} -\pagehead{zsymm}{zsymm} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) - (declare (type (complex double-float) one) (type (complex double-float) zero)) - (defun zsymm (side uplo m n alpha a lda b ldb$ beta c ldc) - (declare (type (array (complex double-float) (*)) c b a) - (type (complex double-float) beta alpha) - (type fixnum ldc ldb$ lda n m) - (type (simple-array character (*)) uplo side)) - (f2cl-lib:with-multi-array-data - ((side character side-%data% side-%offset%) - (uplo character uplo-%data% uplo-%offset%) - (a (complex double-float) a-%data% a-%offset%) - (b (complex double-float) b-%data% b-%offset%) - (c (complex double-float) c-%data% c-%offset%)) - (prog ((temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0)) (i 0) (info 0) (j 0) (k 0) - (nrowa 0) (upper nil)) - (declare (type (complex double-float) temp1 temp2) - (type fixnum i info j k nrowa) - (type (member t nil) upper)) - (cond - ((lsame side "L") - (setf nrowa m)) - (t - (setf nrowa n))) - (setf upper (lsame uplo "U")) - (setf info 0) - (cond - ((and (not (lsame side "L")) (not (lsame side "R"))) - (setf info 1)) - ((and (not upper) (not (lsame uplo "L"))) - (setf info 2)) - ((< m 0) - (setf info 3)) - ((< n 0) - (setf info 4)) - ((< lda (max (the fixnum 1) (the fixnum nrowa))) - (setf info 7)) - ((< ldb$ (max (the fixnum 1) (the fixnum m))) - (setf info 9)) - ((< ldc (max (the fixnum 1) (the fixnum m))) - (setf info 12))) - (cond - ((/= info 0) - (xerbla "ZSYMM " info) - (go end_label))) - (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one))) - (go end_label)) - (cond - ((= alpha zero) - (cond - ((= beta zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))))) - (go end_label))) - (cond - ((lsame side "L") - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))) - (setf temp2 zero) - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add i - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (k j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (k j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* temp1 - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%)) - (* alpha temp2)))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)) - (* temp1 - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%)) - (* alpha temp2)))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i m (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))) - (setf temp2 zero) - (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) - (f2cl-lib:int-add k 1)) - ((> k m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (k j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (k j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp1 - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* temp1 - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%)) - (* alpha temp2)))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)) - (* temp1 - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%)) - (* alpha temp2)))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp1 - (* alpha - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))) - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp1 - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%)))))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)) - (* temp1 - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%)))))))) - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - nil) - (tagbody - (cond - (upper - (setf temp1 - (* alpha - (f2cl-lib:fref a-%data% - (k j) - ((1 lda) (1 *)) - a-%offset%)))) - (t - (setf temp1 - (* alpha - (f2cl-lib:fref a-%data% - (j k) - ((1 lda) (1 *)) - a-%offset%))))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp1 - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))) - (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) (f2cl-lib:int-add k 1)) - ((> k n) nil) - (tagbody - (cond - (upper - (setf temp1 - (* alpha - (f2cl-lib:fref a-%data% - (j k) - ((1 lda) (1 *)) - a-%offset%)))) - (t - (setf temp1 - (* alpha - (f2cl-lib:fref a-%data% - (k j) - ((1 lda) (1 *)) - a-%offset%))))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp1 - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zsymm fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zsyr2k BLAS} -\pagehead{zsyr2k}{zsyr2k} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) - (declare (type (complex double-float) one) (type (complex double-float) zero)) - (defun zsyr2k (uplo trans n k alpha a lda b ldb$ beta c ldc) - (declare (type (array (complex double-float) (*)) c b a) - (type (complex double-float) beta alpha) - (type fixnum ldc ldb$ lda k n) - (type (simple-array character (*)) trans uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (trans character trans-%data% trans-%offset%) - (a (complex double-float) a-%data% a-%offset%) - (b (complex double-float) b-%data% b-%offset%) - (c (complex double-float) c-%data% c-%offset%)) - (prog ((temp1 #C(0.0 0.0)) (temp2 #C(0.0 0.0)) (i 0) (info 0) (j 0) (l 0) - (nrowa 0) (upper nil)) - (declare (type (complex double-float) temp1 temp2) - (type fixnum i info j l nrowa) - (type (member t nil) upper)) - (cond - ((lsame trans "N") - (setf nrowa n)) - (t - (setf nrowa k))) - (setf upper (lsame uplo "U")) - (setf info 0) - (cond - ((and (not upper) (not (lsame uplo "L"))) - (setf info 1)) - ((and (not (lsame trans "N")) (not (lsame trans "T"))) - (setf info 2)) - ((< n 0) - (setf info 3)) - ((< k 0) - (setf info 4)) - ((< lda (max (the fixnum 1) (the fixnum nrowa))) - (setf info 7)) - ((< ldb$ - (max (the fixnum 1) (the fixnum nrowa))) - (setf info 9)) - ((< ldc (max (the fixnum 1) (the fixnum n))) - (setf info 12))) - (cond - ((/= info 0) - (xerbla "ZSYR2K" info) - (go end_label))) - (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) - (go end_label)) - (cond - ((= alpha zero) - (cond - (upper - (cond - ((= beta zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)))))))))) - (t - (cond - ((= beta zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))))))) - (go end_label))) - (cond - ((lsame trans "N") - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))) - ((/= beta one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) - (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:fref b-%data% - (j l) - ((1 ldb$) (1 *)) - b-%offset%))) - (setf temp2 - (* alpha - (f2cl-lib:fref a-%data% - (j l) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* - (f2cl-lib:fref a-%data% - (i l) - ((1 lda) (1 *)) - a-%offset%) - temp1) - (* - (f2cl-lib:fref b-%data% - (i l) - ((1 ldb$) (1 *)) - b-%offset%) - temp2)))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((= beta zero) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))) - ((/= beta one) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (cond - ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) - (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero)) - (setf temp1 - (* alpha - (f2cl-lib:fref b-%data% - (j l) - ((1 ldb$) (1 *)) - b-%offset%))) - (setf temp2 - (* alpha - (f2cl-lib:fref a-%data% - (j l) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* - (f2cl-lib:fref a-%data% - (i l) - ((1 lda) (1 *)) - a-%offset%) - temp1) - (* - (f2cl-lib:fref b-%data% - (i l) - ((1 ldb$) (1 *)) - b-%offset%) - temp2)))))))))))))) - (t - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf temp1 zero) - (setf temp2 zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp1 - (+ temp1 - (* - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (l j) - ((1 ldb$) (1 *)) - b-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref b-%data% - (l i) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:fref a-%data% - (l j) - ((1 lda) (1 *)) - a-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp1) (* alpha temp2)))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)) - (* alpha temp1) - (* alpha temp2)))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf temp1 zero) - (setf temp2 zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp1 - (+ temp1 - (* - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (l j) - ((1 ldb$) (1 *)) - b-%offset%)))) - (setf temp2 - (+ temp2 - (* - (f2cl-lib:fref b-%data% - (l i) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:fref a-%data% - (l j) - ((1 lda) (1 *)) - a-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp1) (* alpha temp2)))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)) - (* alpha temp1) - (* alpha temp2))))))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zsyr2k - fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{zsyrk BLAS} -\pagehead{zsyrk}{zsyrk} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) - (declare (type (complex double-float) one) (type (complex double-float) zero)) - (defun zsyrk (uplo trans n k alpha a lda beta c ldc) - (declare (type (array (complex double-float) (*)) c a) - (type (complex double-float) beta alpha) - (type fixnum ldc lda k n) - (type (simple-array character (*)) trans uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (trans character trans-%data% trans-%offset%) - (a (complex double-float) a-%data% a-%offset%) - (c (complex double-float) c-%data% c-%offset%)) - (prog ((temp #C(0.0 0.0)) (i 0) (info 0) (j 0) (l 0) (nrowa 0) - (upper nil)) - (declare (type (complex double-float) temp) - (type fixnum i info j l nrowa) - (type (member t nil) upper)) - (cond - ((lsame trans "N") - (setf nrowa n)) - (t - (setf nrowa k))) - (setf upper (lsame uplo "U")) - (setf info 0) - (cond - ((and (not upper) (not (lsame uplo "L"))) - (setf info 1)) - ((and (not (lsame trans "N")) (not (lsame trans "T"))) - (setf info 2)) - ((< n 0) - (setf info 3)) - ((< k 0) - (setf info 4)) - ((< lda (max (the fixnum 1) (the fixnum nrowa))) - (setf info 7)) - ((< ldc (max (the fixnum 1) (the fixnum n))) - (setf info 10))) - (cond - ((/= info 0) - (xerbla "ZSYRK " info) - (go end_label))) - (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one))) - (go end_label)) - (cond - ((= alpha zero) - (cond - (upper - (cond - ((= beta zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)))))))))) - (t - (cond - ((= beta zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))))))) - (go end_label))) - (cond - ((lsame trans "N") - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((= beta zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))) - ((/= beta one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref a-%data% - (j l) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i l) - ((1 lda) (1 *)) - a-%offset%))))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((= beta zero) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - zero)))) - ((/= beta one) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref a-%data% - (j l) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i l) - ((1 lda) (1 *)) - a-%offset%))))))))))))))) - (t - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i j) nil) - (tagbody - (setf temp zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref a-%data% - (l j) - ((1 lda) (1 *)) - a-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* alpha temp))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf temp zero) - (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1)) - ((> l k) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (l i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref a-%data% - (l j) - ((1 lda) (1 *)) - a-%offset%)))))) - (cond - ((= beta zero) - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (* alpha temp))) - (t - (setf (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%) - (+ (* alpha temp) - (* beta - (f2cl-lib:fref c-%data% - (i j) - ((1 ldc) (1 *)) - c-%offset%)))))))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::zsyrk fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{ztbmv BLAS} -\pagehead{ztbmv}{ztbmv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero (complex 0.0 0.0))) - (declare (type (complex double-float) zero)) - (defun ztbmv (uplo trans diag n k a lda x incx) - (declare (type (array (complex double-float) (*)) x a) - (type fixnum incx lda k n) - (type (simple-array character (*)) diag trans uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (trans character trans-%data% trans-%offset%) - (diag character diag-%data% diag-%offset%) - (a (complex double-float) a-%data% a-%offset%) - (x (complex double-float) x-%data% x-%offset%)) - (prog ((noconj nil) (nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) - (kplus1 0) (kx 0) (l 0) (temp #C(0.0 0.0))) - (declare (type (member t nil) noconj nounit) - (type fixnum i info ix j jx kplus1 kx l) - (type (complex double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((and (not (lsame trans "N")) - (not (lsame trans "T")) - (not (lsame trans "C"))) - (setf info 2)) - ((and (not (lsame diag "U")) (not (lsame diag "N"))) - (setf info 3)) - ((< n 0) - (setf info 4)) - ((< k 0) - (setf info 5)) - ((< lda (f2cl-lib:int-add k 1)) - (setf info 7)) - ((= incx 0) - (setf info 9))) - (cond - ((/= info 0) - (xerbla "ZTBMV " info) - (go end_label))) - (if (= n 0) (go end_label)) - (setf noconj (lsame trans "T")) - (setf nounit (lsame diag "N")) - (cond - ((<= incx 0) - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx)))) - ((/= incx 1) - (setf kx 1))) - (cond - ((lsame trans "N") - (cond - ((lsame uplo "U") - (setf kplus1 (f2cl-lib:int-add k 1)) - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf l (f2cl-lib:int-sub kplus1 j)) - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k)))) - (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)))))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%))))))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix kx) - (setf l (f2cl-lib:int-sub kplus1 j)) - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k)))) - (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%)))))) - (setf jx (f2cl-lib:int-add jx incx)) - (if (> j k) (setf kx (f2cl-lib:int-add kx incx)))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf l (f2cl-lib:int-sub 1 j)) - (f2cl-lib:fdo (i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k))) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)))))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%))))))))) - (t - (setf kx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (setf jx kx) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix kx) - (setf l (f2cl-lib:int-sub 1 j)) - (f2cl-lib:fdo (i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k))) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx)))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%)))))) - (setf jx (f2cl-lib:int-sub jx incx)) - (if (>= (f2cl-lib:int-sub n j) k) - (setf kx (f2cl-lib:int-sub kx incx)))))))))) - (t - (cond - ((lsame uplo "U") - (setf kplus1 (f2cl-lib:int-add k 1)) - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf l (f2cl-lib:int-sub kplus1 j)) - (cond - (noconj - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k))))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%))))))) - (t - (if nounit - (setf temp - (* temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%))))) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k))))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp)))) - (t - (setf kx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (setf jx kx) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf kx (f2cl-lib:int-sub kx incx)) - (setf ix kx) - (setf l (f2cl-lib:int-sub kplus1 j)) - (cond - (noconj - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k))))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx))))) - (t - (if nounit - (setf temp - (* temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%))))) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k))))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx)))))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-sub jx incx))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf l (f2cl-lib:int-sub 1 j)) - (cond - (noconj - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k)))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%))))))) - (t - (if nounit - (setf temp - (* temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%))))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k)))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp)))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf kx (f2cl-lib:int-add kx incx)) - (setf ix kx) - (setf l (f2cl-lib:int-sub 1 j)) - (cond - (noconj - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k)))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx))))) - (t - (if nounit - (setf temp - (* temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%))))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k)))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-add jx incx)))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::ztbmv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{ztbsv BLAS} -\pagehead{ztbsv}{ztbsv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero (complex 0.0 0.0))) - (declare (type (complex double-float) zero)) - (defun ztbsv (uplo trans diag n k a lda x incx) - (declare (type (array (complex double-float) (*)) x a) - (type fixnum incx lda k n) - (type (simple-array character (*)) diag trans uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (trans character trans-%data% trans-%offset%) - (diag character diag-%data% diag-%offset%) - (a (complex double-float) a-%data% a-%offset%) - (x (complex double-float) x-%data% x-%offset%)) - (prog ((noconj nil) (nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) - (kplus1 0) (kx 0) (l 0) (temp #C(0.0 0.0))) - (declare (type (member t nil) noconj nounit) - (type fixnum i info ix j jx kplus1 kx l) - (type (complex double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((and (not (lsame trans "N")) - (not (lsame trans "T")) - (not (lsame trans "C"))) - (setf info 2)) - ((and (not (lsame diag "U")) (not (lsame diag "N"))) - (setf info 3)) - ((< n 0) - (setf info 4)) - ((< k 0) - (setf info 5)) - ((< lda (f2cl-lib:int-add k 1)) - (setf info 7)) - ((= incx 0) - (setf info 9))) - (cond - ((/= info 0) - (xerbla "ZTBSV " info) - (go end_label))) - (if (= n 0) (go end_label)) - (setf noconj (lsame trans "T")) - (setf nounit (lsame diag "N")) - (cond - ((<= incx 0) - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx)))) - ((/= incx 1) - (setf kx 1))) - (cond - ((lsame trans "N") - (cond - ((lsame uplo "U") - (setf kplus1 (f2cl-lib:int-add k 1)) - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf l (f2cl-lib:int-sub kplus1 j)) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k))))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%))))))))))) - (t - (setf kx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (setf jx kx) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf kx (f2cl-lib:int-sub kx incx)) - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf ix kx) - (setf l (f2cl-lib:int-sub kplus1 j)) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k))))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx)))))) - (setf jx (f2cl-lib:int-sub jx incx))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf l (f2cl-lib:int-sub 1 j)) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k)))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%))))))))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf kx (f2cl-lib:int-add kx incx)) - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf ix kx) - (setf l (f2cl-lib:int-sub 1 j)) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k)))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))))) - (setf jx (f2cl-lib:int-add jx incx))))))))) - (t - (cond - ((lsame uplo "U") - (setf kplus1 (f2cl-lib:int-add k 1)) - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf l (f2cl-lib:int-sub kplus1 j)) - (cond - (noconj - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k)))) - (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%))))) - (t - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k)))) - (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%))))))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp)))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf ix kx) - (setf l (f2cl-lib:int-sub kplus1 j)) - (cond - (noconj - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k)))) - (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%))))) - (t - (f2cl-lib:fdo (i - (max (the fixnum 1) - (the fixnum - (f2cl-lib:int-add j - (f2cl-lib:int-sub - k)))) - (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (kplus1 j) - ((1 lda) (1 *)) - a-%offset%))))))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-add jx incx)) - (if (> j k) (setf kx (f2cl-lib:int-add kx incx)))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf l (f2cl-lib:int-sub 1 j)) - (cond - (noconj - (f2cl-lib:fdo (i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k))) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%))))) - (t - (f2cl-lib:fdo (i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k))) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%))))))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp)))) - (t - (setf kx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (setf jx kx) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf ix kx) - (setf l (f2cl-lib:int-sub 1 j)) - (cond - (noconj - (f2cl-lib:fdo (i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k))) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%))))) - (t - (f2cl-lib:fdo (i - (min (the fixnum n) - (the fixnum - (f2cl-lib:int-add j k))) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - ((f2cl-lib:int-add l i) - j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (1 j) - ((1 lda) (1 *)) - a-%offset%))))))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-sub jx incx)) - (if (>= (f2cl-lib:int-sub n j) k) - (setf kx (f2cl-lib:int-sub kx incx))))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::ztbsv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{ztpmv BLAS} -\pagehead{ztpmv}{ztpmv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero (complex 0.0 0.0))) - (declare (type (complex double-float) zero)) - (defun ztpmv (uplo trans diag n ap x incx) - (declare (type (array (complex double-float) (*)) x ap) - (type fixnum incx n) - (type (simple-array character (*)) diag trans uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (trans character trans-%data% trans-%offset%) - (diag character diag-%data% diag-%offset%) - (ap (complex double-float) ap-%data% ap-%offset%) - (x (complex double-float) x-%data% x-%offset%)) - (prog ((noconj nil) (nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0) - (kk 0) (kx 0) (temp #C(0.0 0.0))) - (declare (type (member t nil) noconj nounit) - (type fixnum i info ix j jx k kk kx) - (type (complex double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((and (not (lsame trans "N")) - (not (lsame trans "T")) - (not (lsame trans "C"))) - (setf info 2)) - ((and (not (lsame diag "U")) (not (lsame diag "N"))) - (setf info 3)) - ((< n 0) - (setf info 4)) - ((= incx 0) - (setf info 7))) - (cond - ((/= info 0) - (xerbla "ZTPMV " info) - (go end_label))) - (if (= n 0) (go end_label)) - (setf noconj (lsame trans "T")) - (setf nounit (lsame diag "N")) - (cond - ((<= incx 0) - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx)))) - ((/= incx 1) - (setf kx 1))) - (cond - ((lsame trans "N") - (cond - ((lsame uplo "U") - (setf kk 1) - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf k kk) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf k (f2cl-lib:int-add k 1)))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%)))))) - (setf kk (f2cl-lib:int-add kk j))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix kx) - (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - j - (f2cl-lib:int-sub - 2))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%)))))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf kk (f2cl-lib:int-add kk j))))))) - (t - (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf k kk) - (f2cl-lib:fdo (i n - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf k (f2cl-lib:int-sub k 1)))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-add - (f2cl-lib:int-sub kk n) - j)) - ((1 *)) - ap-%offset%)))))) - (setf kk - (f2cl-lib:int-sub kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1)))))) - (t - (setf kx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (setf jx kx) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix kx) - (f2cl-lib:fdo (k kk - (f2cl-lib:int-add k - (f2cl-lib:int-sub 1))) - ((> k - (f2cl-lib:int-add kk - (f2cl-lib:int-sub - (f2cl-lib:int-add - n - (f2cl-lib:int-sub - (f2cl-lib:int-add - j - 1)))))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx)))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-add - (f2cl-lib:int-sub kk n) - j)) - ((1 *)) - ap-%offset%)))))) - (setf jx (f2cl-lib:int-sub jx incx)) - (setf kk - (f2cl-lib:int-sub kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1)))))))))) - (t - (cond - ((lsame uplo "U") - (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf k (f2cl-lib:int-sub kk 1)) - (cond - (noconj - (if nounit - (setf temp - (* temp - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)))) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))) - (setf k (f2cl-lib:int-sub k 1))))) - (t - (if nounit - (setf temp - (* temp - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%))))) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))) - (setf k (f2cl-lib:int-sub k 1)))))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp) - (setf kk (f2cl-lib:int-sub kk j))))) - (t - (setf jx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf ix jx) - (cond - (noconj - (if nounit - (setf temp - (* temp - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)))) - (f2cl-lib:fdo (k - (f2cl-lib:int-add kk - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add k - (f2cl-lib:int-sub 1))) - ((> k - (f2cl-lib:int-add kk - (f2cl-lib:int-sub - j) - 1)) - nil) - (tagbody - (setf ix (f2cl-lib:int-sub ix incx)) - (setf temp - (+ temp - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%))))))) - (t - (if nounit - (setf temp - (* temp - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%))))) - (f2cl-lib:fdo (k - (f2cl-lib:int-add kk - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add k - (f2cl-lib:int-sub 1))) - ((> k - (f2cl-lib:int-add kk - (f2cl-lib:int-sub - j) - 1)) - nil) - (tagbody - (setf ix (f2cl-lib:int-sub ix incx)) - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))))))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-sub jx incx)) - (setf kk (f2cl-lib:int-sub kk j))))))) - (t - (setf kk 1) - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf k (f2cl-lib:int-add kk 1)) - (cond - (noconj - (if nounit - (setf temp - (* temp - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))) - (setf k (f2cl-lib:int-add k 1))))) - (t - (if nounit - (setf temp - (* temp - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%))))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))) - (setf k (f2cl-lib:int-add k 1)))))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp) - (setf kk - (f2cl-lib:int-add kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1)))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf ix jx) - (cond - (noconj - (if nounit - (setf temp - (* temp - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)))) - (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) - (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - n - (f2cl-lib:int-sub - j))) - nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf temp - (+ temp - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%))))))) - (t - (if nounit - (setf temp - (* temp - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%))))) - (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) - (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - n - (f2cl-lib:int-sub - j))) - nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))))))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-add jx incx)) - (setf kk - (f2cl-lib:int-add kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1))))))))))) - end_label - (return (values nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::ztpmv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum - (array (complex double-float) (*)) - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{ztpsv BLAS} -\pagehead{ztpsv}{ztpsv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero (complex 0.0 0.0))) - (declare (type (complex double-float) zero)) - (defun ztpsv (uplo trans diag n ap x incx) - (declare (type (array (complex double-float) (*)) x ap) - (type fixnum incx n) - (type (simple-array character (*)) diag trans uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (trans character trans-%data% trans-%offset%) - (diag character diag-%data% diag-%offset%) - (ap (complex double-float) ap-%data% ap-%offset%) - (x (complex double-float) x-%data% x-%offset%)) - (prog ((noconj nil) (nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0) - (kk 0) (kx 0) (temp #C(0.0 0.0))) - (declare (type (member t nil) noconj nounit) - (type fixnum i info ix j jx k kk kx) - (type (complex double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((and (not (lsame trans "N")) - (not (lsame trans "T")) - (not (lsame trans "C"))) - (setf info 2)) - ((and (not (lsame diag "U")) (not (lsame diag "N"))) - (setf info 3)) - ((< n 0) - (setf info 4)) - ((= incx 0) - (setf info 7))) - (cond - ((/= info 0) - (xerbla "ZTPSV " info) - (go end_label))) - (if (= n 0) (go end_label)) - (setf noconj (lsame trans "T")) - (setf nounit (lsame diag "N")) - (cond - ((<= incx 0) - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx)))) - ((/= incx 1) - (setf kx 1))) - (cond - ((lsame trans "N") - (cond - ((lsame uplo "U") - (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf k (f2cl-lib:int-sub kk 1)) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf k (f2cl-lib:int-sub k 1)))))) - (setf kk (f2cl-lib:int-sub kk j))))) - (t - (setf jx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix jx) - (f2cl-lib:fdo (k - (f2cl-lib:int-add kk - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add k - (f2cl-lib:int-sub 1))) - ((> k - (f2cl-lib:int-add kk - (f2cl-lib:int-sub - j) - 1)) - nil) - (tagbody - (setf ix (f2cl-lib:int-sub ix incx)) - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))))))) - (setf jx (f2cl-lib:int-sub jx incx)) - (setf kk (f2cl-lib:int-sub kk j))))))) - (t - (setf kk 1) - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf k (f2cl-lib:int-add kk 1)) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))) - (setf k (f2cl-lib:int-add k 1)))))) - (setf kk - (f2cl-lib:int-add kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1)))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref ap-%data% - (kk) - ((1 *)) - ap-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix jx) - (f2cl-lib:fdo (k (f2cl-lib:int-add kk 1) - (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - n - (f2cl-lib:int-sub - j))) - nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)))))))) - (setf jx (f2cl-lib:int-add jx incx)) - (setf kk - (f2cl-lib:int-add kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1)))))))))) - (t - (cond - ((lsame uplo "U") - (setf kk 1) - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf k kk) - (cond - (noconj - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))) - (setf k (f2cl-lib:int-add k 1)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%))))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))) - (setf k (f2cl-lib:int-add k 1)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk - j) - 1)) - ((1 *)) - ap-%offset%))))))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp) - (setf kk (f2cl-lib:int-add kk j))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf ix kx) - (cond - (noconj - (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - j - (f2cl-lib:int-sub - 2))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk j) - 1)) - ((1 *)) - ap-%offset%))))) - (t - (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add kk - j - (f2cl-lib:int-sub - 2))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-sub - (f2cl-lib:int-add kk - j) - 1)) - ((1 *)) - ap-%offset%))))))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-add jx incx)) - (setf kk (f2cl-lib:int-add kk j))))))) - (t - (setf kk (the fixnum (truncate (* n (+ n 1)) 2))) - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (setf k kk) - (cond - (noconj - (f2cl-lib:fdo (i n - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))) - (setf k (f2cl-lib:int-sub k 1)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-add - (f2cl-lib:int-sub kk n) - j)) - ((1 *)) - ap-%offset%))))) - (t - (f2cl-lib:fdo (i n - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))) - (setf k (f2cl-lib:int-sub k 1)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-add - (f2cl-lib:int-sub kk - n) - j)) - ((1 *)) - ap-%offset%))))))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp) - (setf kk - (f2cl-lib:int-sub kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1)))))) - (t - (setf kx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (setf jx kx) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf ix kx) - (cond - (noconj - (f2cl-lib:fdo (k kk - (f2cl-lib:int-add k - (f2cl-lib:int-sub 1))) - ((> k - (f2cl-lib:int-add kk - (f2cl-lib:int-sub - (f2cl-lib:int-add - n - (f2cl-lib:int-sub - (f2cl-lib:int-add - j - 1)))))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-add - (f2cl-lib:int-sub kk n) - j)) - ((1 *)) - ap-%offset%))))) - (t - (f2cl-lib:fdo (k kk - (f2cl-lib:int-add k - (f2cl-lib:int-sub 1))) - ((> k - (f2cl-lib:int-add kk - (f2cl-lib:int-sub - (f2cl-lib:int-add - n - (f2cl-lib:int-sub - (f2cl-lib:int-add - j - 1)))))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - (k) - ((1 *)) - ap-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:dconjg - (f2cl-lib:fref ap-%data% - ((f2cl-lib:int-add - (f2cl-lib:int-sub kk - n) - j)) - ((1 *)) - ap-%offset%))))))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-sub jx incx)) - (setf kk - (f2cl-lib:int-sub kk - (f2cl-lib:int-add - (f2cl-lib:int-sub n j) - 1))))))))))) - end_label - (return (values nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::ztpsv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum - (array (complex double-float) (*)) - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{ztrmm BLAS} -\pagehead{ztrmm}{ztrmm} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) - (declare (type (complex double-float) one) (type (complex double-float) zero)) - (defun ztrmm (side uplo transa diag m n alpha a lda b ldb$) - (declare (type (array (complex double-float) (*)) b a) - (type (complex double-float) alpha) - (type fixnum ldb$ lda n m) - (type (simple-array character (*)) diag transa uplo side)) - (f2cl-lib:with-multi-array-data - ((side character side-%data% side-%offset%) - (uplo character uplo-%data% uplo-%offset%) - (transa character transa-%data% transa-%offset%) - (diag character diag-%data% diag-%offset%) - (a (complex double-float) a-%data% a-%offset%) - (b (complex double-float) b-%data% b-%offset%)) - (prog ((temp #C(0.0 0.0)) (i 0) (info 0) (j 0) (k 0) (nrowa 0) - (lside nil) (noconj nil) (nounit nil) (upper nil)) - (declare (type (complex double-float) temp) - (type fixnum i info j k nrowa) - (type (member t nil) lside noconj nounit upper)) - (setf lside (lsame side "L")) - (cond - (lside - (setf nrowa m)) - (t - (setf nrowa n))) - (setf noconj (lsame transa "T")) - (setf nounit (lsame diag "N")) - (setf upper (lsame uplo "U")) - (setf info 0) - (cond - ((and (not lside) (not (lsame side "R"))) - (setf info 1)) - ((and (not upper) (not (lsame uplo "L"))) - (setf info 2)) - ((and (not (lsame transa "N")) - (not (lsame transa "T")) - (not (lsame transa "C"))) - (setf info 3)) - ((and (not (lsame diag "U")) (not (lsame diag "N"))) - (setf info 4)) - ((< m 0) - (setf info 5)) - ((< n 0) - (setf info 6)) - ((< lda (max (the fixnum 1) (the fixnum nrowa))) - (setf info 9)) - ((< ldb$ (max (the fixnum 1) (the fixnum m))) - (setf info 11))) - (cond - ((/= info 0) - (xerbla "ZTRMM " info) - (go end_label))) - (if (= n 0) (go end_label)) - (cond - ((= alpha zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - zero))))) - (go end_label))) - (cond - (lside - (cond - ((lsame transa "N") - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k m) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add k - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (+ - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i k) - ((1 lda) (1 *)) - a-%offset%)))))) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%)))) - (setf (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - temp)))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (k m - (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) - ((> k 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%))) - (setf (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - temp) - (if nounit - (setf (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (* - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i (f2cl-lib:int-add k 1) - (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (+ - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i k) - ((1 lda) (1 *)) - a-%offset%))))))))))))))) - (t - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i m - (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%)) - (cond - (noconj - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add i - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%))))))) - (t - (if nounit - (setf temp - (* temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%))))) - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add i - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%)))))))) - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* alpha temp))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%)) - (cond - (noconj - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) - (f2cl-lib:int-add k 1)) - ((> k m) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%))))))) - (t - (if nounit - (setf temp - (* temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%))))) - (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) - (f2cl-lib:int-add k 1)) - ((> k m) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%)))))))) - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* alpha temp))))))))))) - (t - (cond - ((lsame transa "N") - (cond - (upper - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp alpha) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))))) - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref a-%data% - (k j) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (+ - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%))))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp alpha) - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))))) - (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) - (f2cl-lib:int-add k 1)) - ((> k n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) - (setf temp - (* alpha - (f2cl-lib:fref a-%data% - (k j) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (+ - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%))))))))))))))) - (t - (cond - (upper - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k n) nil) - (tagbody - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j - (f2cl-lib:int-add k - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) - (cond - (noconj - (setf temp - (* alpha - (f2cl-lib:fref a-%data% - (j k) - ((1 lda) (1 *)) - a-%offset%)))) - (t - (setf temp - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (j k) - ((1 lda) (1 *)) - a-%offset%)))))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (+ - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))))) - (setf temp alpha) - (cond - (nounit - (cond - (noconj - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%)))) - (t - (setf temp - (* temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%)))))))) - (cond - ((/= temp one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))))) - (t - (f2cl-lib:fdo (k n (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) - ((> k 1) nil) - (tagbody - (f2cl-lib:fdo (j (f2cl-lib:int-add k 1) - (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) - (cond - (noconj - (setf temp - (* alpha - (f2cl-lib:fref a-%data% - (j k) - ((1 lda) (1 *)) - a-%offset%)))) - (t - (setf temp - (* alpha - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (j k) - ((1 lda) (1 *)) - a-%offset%)))))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (+ - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))))) - (setf temp alpha) - (cond - (nounit - (cond - (noconj - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%)))) - (t - (setf temp - (* temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%)))))))) - (cond - ((/= temp one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%))))))))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::ztrmm fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{ztrmv BLAS} -\pagehead{ztrmv}{ztrmv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero (complex 0.0 0.0))) - (declare (type (complex double-float) zero)) - (defun ztrmv (uplo trans diag n a lda x incx) - (declare (type (array (complex double-float) (*)) x a) - (type fixnum incx lda n) - (type (simple-array character (*)) diag trans uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (trans character trans-%data% trans-%offset%) - (diag character diag-%data% diag-%offset%) - (a (complex double-float) a-%data% a-%offset%) - (x (complex double-float) x-%data% x-%offset%)) - (prog ((noconj nil) (nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) - (kx 0) (temp #C(0.0 0.0))) - (declare (type (member t nil) noconj nounit) - (type fixnum i info ix j jx kx) - (type (complex double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((and (not (lsame trans "N")) - (not (lsame trans "T")) - (not (lsame trans "C"))) - (setf info 2)) - ((and (not (lsame diag "U")) (not (lsame diag "N"))) - (setf info 3)) - ((< n 0) - (setf info 4)) - ((< lda (max (the fixnum 1) (the fixnum n))) - (setf info 6)) - ((= incx 0) - (setf info 8))) - (cond - ((/= info 0) - (xerbla "ZTRMV " info) - (go end_label))) - (if (= n 0) (go end_label)) - (setf noconj (lsame trans "T")) - (setf nounit (lsame diag "N")) - (cond - ((<= incx 0) - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx)))) - ((/= incx 1) - (setf kx 1))) - (cond - ((lsame trans "N") - (cond - ((lsame uplo "U") - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))))))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix kx) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))))) - (setf jx (f2cl-lib:int-add jx incx))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (f2cl-lib:fdo (i n - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))))))))) - (t - (setf kx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (setf jx kx) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix kx) - (f2cl-lib:fdo (i n - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (+ - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx)))) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (* - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))))) - (setf jx (f2cl-lib:int-sub jx incx))))))))) - (t - (cond - ((lsame uplo "U") - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (cond - (noconj - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%))))))) - (t - (if nounit - (setf temp - (* temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))))) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp)))) - (t - (setf jx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf ix jx) - (cond - (noconj - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf ix (f2cl-lib:int-sub ix incx)) - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%))))))) - (t - (if nounit - (setf temp - (* temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))))) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf ix (f2cl-lib:int-sub ix incx)) - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))))))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-sub jx incx))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (cond - (noconj - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%))))))) - (t - (if nounit - (setf temp - (* temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp)))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (setf ix jx) - (cond - (noconj - (if nounit - (setf temp - (* temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf temp - (+ temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%))))))) - (t - (if nounit - (setf temp - (* temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))))) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf temp - (+ temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))))))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-add jx incx)))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::ztrmv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{ztrsm BLAS} -\pagehead{ztrsm}{ztrsm} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((one (complex 1.0 0.0)) (zero (complex 0.0 0.0))) - (declare (type (complex double-float) one) (type (complex double-float) zero)) - (defun ztrsm (side uplo transa diag m n alpha a lda b ldb$) - (declare (type (array (complex double-float) (*)) b a) - (type (complex double-float) alpha) - (type fixnum ldb$ lda n m) - (type (simple-array character (*)) diag transa uplo side)) - (f2cl-lib:with-multi-array-data - ((side character side-%data% side-%offset%) - (uplo character uplo-%data% uplo-%offset%) - (transa character transa-%data% transa-%offset%) - (diag character diag-%data% diag-%offset%) - (a (complex double-float) a-%data% a-%offset%) - (b (complex double-float) b-%data% b-%offset%)) - (prog ((temp #C(0.0 0.0)) (i 0) (info 0) (j 0) (k 0) (nrowa 0) - (lside nil) (noconj nil) (nounit nil) (upper nil)) - (declare (type (complex double-float) temp) - (type fixnum i info j k nrowa) - (type (member t nil) lside noconj nounit upper)) - (setf lside (lsame side "L")) - (cond - (lside - (setf nrowa m)) - (t - (setf nrowa n))) - (setf noconj (lsame transa "T")) - (setf nounit (lsame diag "N")) - (setf upper (lsame uplo "U")) - (setf info 0) - (cond - ((and (not lside) (not (lsame side "R"))) - (setf info 1)) - ((and (not upper) (not (lsame uplo "L"))) - (setf info 2)) - ((and (not (lsame transa "N")) - (not (lsame transa "T")) - (not (lsame transa "C"))) - (setf info 3)) - ((and (not (lsame diag "U")) (not (lsame diag "N"))) - (setf info 4)) - ((< m 0) - (setf info 5)) - ((< n 0) - (setf info 6)) - ((< lda (max (the fixnum 1) (the fixnum nrowa))) - (setf info 9)) - ((< ldb$ (max (the fixnum 1) (the fixnum m))) - (setf info 11))) - (cond - ((/= info 0) - (xerbla "ZTRSM " info) - (go end_label))) - (if (= n 0) (go end_label)) - (cond - ((= alpha zero) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - zero))))) - (go end_label))) - (cond - (lside - (cond - ((lsame transa "N") - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= alpha one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* alpha - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))))))) - (f2cl-lib:fdo (k m - (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) - ((> k 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) - (if nounit - (setf (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (/ - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add k - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (- - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:fref a-%data% - (i k) - ((1 lda) (1 *)) - a-%offset%))))))))))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= alpha one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* alpha - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))))))) - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k m) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref b (k j) ((1 ldb$) (1 *))) zero) - (if nounit - (setf (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (/ - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%)))) - (f2cl-lib:fdo (i (f2cl-lib:int-add k 1) - (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (- - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%) - (f2cl-lib:fref a-%data% - (i k) - ((1 lda) (1 *)) - a-%offset%))))))))))))))) - (t - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf temp - (* alpha - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))) - (cond - (noconj - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add i - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%)))))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%))))) - (t - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add i - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%)))))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%))))))) - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - temp)))))) - (t - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (f2cl-lib:fdo (i m - (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf temp - (* alpha - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))) - (cond - (noconj - (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) - (f2cl-lib:int-add k 1)) - ((> k m) nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%)))))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%))))) - (t - (f2cl-lib:fdo (k (f2cl-lib:int-add i 1) - (f2cl-lib:int-add k 1)) - ((> k m) nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (k i) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref b-%data% - (k j) - ((1 ldb$) (1 *)) - b-%offset%)))))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (i i) - ((1 lda) (1 *)) - a-%offset%))))))) - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - temp)))))))))) - (t - (cond - ((lsame transa "N") - (cond - (upper - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= alpha one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* alpha - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))))))) - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (- - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* - (f2cl-lib:fref a-%data% - (k j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))))) - (cond - (nounit - (setf temp - (/ one - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%)))))))))) - (t - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= alpha one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* alpha - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%))))))) - (f2cl-lib:fdo (k (f2cl-lib:int-add j 1) - (f2cl-lib:int-add k 1)) - ((> k n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (k j) ((1 lda) (1 *))) zero) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (- - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* - (f2cl-lib:fref a-%data% - (k j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))))) - (cond - (nounit - (setf temp - (/ one - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%)))))))))))) - (t - (cond - (upper - (f2cl-lib:fdo (k n (f2cl-lib:int-add k (f2cl-lib:int-sub 1))) - ((> k 1) nil) - (tagbody - (cond - (nounit - (cond - (noconj - (setf temp - (/ one - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%)))) - (t - (setf temp - (/ one - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%)))))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%))))))) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j - (f2cl-lib:int-add k - (f2cl-lib:int-sub 1))) - nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) - (cond - (noconj - (setf temp - (f2cl-lib:fref a-%data% - (j k) - ((1 lda) (1 *)) - a-%offset%))) - (t - (setf temp - (coerce - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (j k) - ((1 lda) (1 *)) - a-%offset%)) - '(complex double-float))))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (- - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))))) - (cond - ((/= alpha one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%) - (* alpha - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))))) - (t - (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1)) - ((> k n) nil) - (tagbody - (cond - (nounit - (cond - (noconj - (setf temp - (/ one - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%)))) - (t - (setf temp - (/ one - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (k k) - ((1 lda) (1 *)) - a-%offset%)))))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%))))))) - (f2cl-lib:fdo (j (f2cl-lib:int-add k 1) - (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref a (j k) ((1 lda) (1 *))) zero) - (cond - (noconj - (setf temp - (f2cl-lib:fref a-%data% - (j k) - ((1 lda) (1 *)) - a-%offset%))) - (t - (setf temp - (coerce - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (j k) - ((1 lda) (1 *)) - a-%offset%)) - '(complex double-float))))) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (- - (f2cl-lib:fref b-%data% - (i j) - ((1 ldb$) (1 *)) - b-%offset%) - (* temp - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%)))))))))) - (cond - ((/= alpha one) - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i m) nil) - (tagbody - (setf (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%) - (* alpha - (f2cl-lib:fref b-%data% - (i k) - ((1 ldb$) (1 *)) - b-%offset%))))))))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::ztrsm fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum fixnum - ((complex double-float)) - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{ztrsv BLAS} -\pagehead{ztrsv}{ztrsv} -%\pagepic{ps/v104algebraicfunction.ps}{AF}{1.00} - -<>= -(let* ((zero (complex 0.0 0.0))) - (declare (type (complex double-float) zero)) - (defun ztrsv (uplo trans diag n a lda x incx) - (declare (type (array (complex double-float) (*)) x a) - (type fixnum incx lda n) - (type (simple-array character (*)) diag trans uplo)) - (f2cl-lib:with-multi-array-data - ((uplo character uplo-%data% uplo-%offset%) - (trans character trans-%data% trans-%offset%) - (diag character diag-%data% diag-%offset%) - (a (complex double-float) a-%data% a-%offset%) - (x (complex double-float) x-%data% x-%offset%)) - (prog ((noconj nil) (nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) - (kx 0) (temp #C(0.0 0.0))) - (declare (type (member t nil) noconj nounit) - (type fixnum i info ix j jx kx) - (type (complex double-float) temp)) - (setf info 0) - (cond - ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) - (setf info 1)) - ((and (not (lsame trans "N")) - (not (lsame trans "T")) - (not (lsame trans "C"))) - (setf info 2)) - ((and (not (lsame diag "U")) (not (lsame diag "N"))) - (setf info 3)) - ((< n 0) - (setf info 4)) - ((< lda (max (the fixnum 1) (the fixnum n))) - (setf info 6)) - ((= incx 0) - (setf info 8))) - (cond - ((/= info 0) - (xerbla "ZTRSV " info) - (go end_label))) - (if (= n 0) (go end_label)) - (setf noconj (lsame trans "T")) - (setf nounit (lsame diag "N")) - (cond - ((<= incx 0) - (setf kx - (f2cl-lib:int-sub 1 - (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) - incx)))) - ((/= incx 1) - (setf kx 1))) - (cond - ((lsame trans "N") - (cond - ((lsame uplo "U") - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%))))))))))) - (t - (setf jx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix jx) - (f2cl-lib:fdo (i - (f2cl-lib:int-add j - (f2cl-lib:int-sub 1)) - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i 1) nil) - (tagbody - (setf ix (f2cl-lib:int-sub ix incx)) - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))))))) - (setf jx (f2cl-lib:int-sub jx incx))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (j) ((1 *))) zero) - (if nounit - (setf (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (j) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%))))))))))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (cond - ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) - (if nounit - (setf (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (/ - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%) - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%)))) - (setf temp - (f2cl-lib:fref x-%data% - (jx) - ((1 *)) - x-%offset%)) - (setf ix jx) - (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) - (f2cl-lib:int-add i 1)) - ((> i n) nil) - (tagbody - (setf ix (f2cl-lib:int-add ix incx)) - (setf (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (- - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%) - (* temp - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)))))))) - (setf jx (f2cl-lib:int-add jx incx))))))))) - (t - (cond - ((lsame uplo "U") - (cond - ((= incx 1) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (cond - (noconj - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))))))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp)))) - (t - (setf jx kx) - (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) - ((> j n) nil) - (tagbody - (setf ix kx) - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (cond - (noconj - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))))) - (t - (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) - ((> i - (f2cl-lib:int-add j - (f2cl-lib:int-sub - 1))) - nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-add ix incx)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))))))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-add jx incx))))))) - (t - (cond - ((= incx 1) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf temp - (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) - (cond - (noconj - (f2cl-lib:fdo (i n - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))))) - (t - (f2cl-lib:fdo (i n - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (i) - ((1 *)) - x-%offset%)))))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))))))) - (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) - temp)))) - (t - (setf kx - (f2cl-lib:int-add kx - (f2cl-lib:int-mul - (f2cl-lib:int-sub n 1) - incx))) - (setf jx kx) - (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) - ((> j 1) nil) - (tagbody - (setf ix kx) - (setf temp - (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) - (cond - (noconj - (f2cl-lib:fdo (i n - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))))) - (t - (f2cl-lib:fdo (i n - (f2cl-lib:int-add i - (f2cl-lib:int-sub 1))) - ((> i (f2cl-lib:int-add j 1)) nil) - (tagbody - (setf temp - (- temp - (* - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (i j) - ((1 lda) (1 *)) - a-%offset%)) - (f2cl-lib:fref x-%data% - (ix) - ((1 *)) - x-%offset%)))) - (setf ix (f2cl-lib:int-sub ix incx)))) - (if nounit - (setf temp - (/ temp - (f2cl-lib:dconjg - (f2cl-lib:fref a-%data% - (j j) - ((1 lda) (1 *)) - a-%offset%))))))) - (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) - temp) - (setf jx (f2cl-lib:int-sub jx incx)))))))))) - end_label - (return (values nil nil nil nil nil nil nil nil)))))) - -(in-package #-gcl #:cl-user #+gcl "CL-USER") -#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) -(eval-when (:load-toplevel :compile-toplevel :execute) - (setf (gethash 'fortran-to-lisp::ztrsv fortran-to-lisp::*f2cl-function-info*) - (fortran-to-lisp::make-f2cl-finfo - :arg-types '((simple-array character (1)) - (simple-array character (1)) - (simple-array character (1)) - fixnum - (array (complex double-float) (*)) - fixnum - (array (complex double-float) (*)) - fixnum) - :return-values '(nil nil nil nil nil nil nil nil) - :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) +;(in-package #-gcl #:cl-user #+gcl "CL-USER") +;#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) +;(eval-when (:load-toplevel :compile-toplevel :execute) +; (setf (gethash 'fortran-to-lisp::zlassq +; fortran-to-lisp::*f2cl-function-info*) +; (fortran-to-lisp::make-f2cl-finfo +; :arg-types '(fixnum +; (array (complex double-float) (*)) +; fixnum (double-float) +; (double-float)) +; :return-values '(nil nil nil fortran-to-lisp::scale +; fortran-to-lisp::sumsq) +; :calls 'nil))) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Chunk collections} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -<<*>>= -<> -<> -<> -<> -<> -<> -<>= -<> +<>= +(in-package "BOOT") <> +@ +<>= <> <> diff --git a/changelog b/changelog index 8ae831c..cb9fa24 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,8 @@ +20100402 tpd src/axiom-website/patches.html 20100402.01.tpd.patch +20100402 tpd src/interp/Makefile add Volume 10.5 Axiom Numerics +20100402 tpd src/algebra/Makefile add Volume 10.5 Axiom Numerics +20100402 tpd src/Makefile add Volume 10.5 Axiom Numerics +20100402 tpd books/bookvol10.5 add Volume 10.5 Axiom Numerics 20100401 tpd src/axiom-website/patches.html 20100401.03.tpd.patch 20100401 tpd books/bookvol4 document steps for adding algebra 20100401 tpd src/axiom-website/patches.html 20100401.02.tpd.patch diff --git a/src/Makefile.pamphlet b/src/Makefile.pamphlet index 7d02873..eb05c33 100644 --- a/src/Makefile.pamphlet +++ b/src/Makefile.pamphlet @@ -270,6 +270,7 @@ interpdir: ${SRC}/interp/Makefile @mkdir -p ${MNT}/${SYS}/doc/src/interp @cp ${SPD}/books/bookvol5.pamphlet interp @cp ${SPD}/books/bookvol9.pamphlet interp + @cp ${SPD}/books/bookvol10.5.pamphlet interp @(cd ${MNT}/${SYS}/doc ; \ ${TANGLE} -R"util.ht" ${SPD}/books/bookvol7.1.pamphlet >util.ht ) @(cd interp ; ${ENV} ${MAKE} ) @@ -501,6 +502,7 @@ ${SRC}/algebra/Makefile: ${SRC}/algebra/Makefile.pamphlet cp ${SPD}/books/bookvol10.2.pamphlet bookvol10.2.spad.pamphlet ; \ cp ${SPD}/books/bookvol10.3.pamphlet bookvol10.3.spad.pamphlet ; \ cp ${SPD}/books/bookvol10.4.pamphlet bookvol10.4.spad.pamphlet ; \ + cp ${SPD}/books/bookvol10.5.pamphlet bookvol10.5.spad.pamphlet ; \ echo 30a extracting findAlgebraFiles from \ ${SRC}/algebra/Makefile.pamphlet ; \ ${TANGLE} -t8 -RfindAlgebraFiles Makefile.pamphlet \ diff --git a/src/algebra/Makefile.pamphlet b/src/algebra/Makefile.pamphlet index 8fe8448..ceaf8ab 100644 --- a/src/algebra/Makefile.pamphlet +++ b/src/algebra/Makefile.pamphlet @@ -2220,7 +2220,8 @@ TRANFUN VSPACE XPOLYC LAYER7=\ ${OUT}/A1AGG.o ${OUT}/A1AGG-.o ${OUT}/ARR2CAT.o ${OUT}/ARR2CAT-.o \ - ${OUT}/ASP34.o ${OUT}/BBTREE.o ${OUT}/BFUNCT.o ${OUT}/BPADIC.o \ + ${OUT}/ASP34.o ${OUT}/BBTREE.o ${OUT}/BFUNCT.o ${OUT}/BLAS1.o \ + ${OUT}/BPADIC.o \ ${OUT}/BTREE.o ${OUT}/CRAPACK.o ${OUT}/DEQUEUE.o ${OUT}/DLIST.o \ ${OUT}/DRAWCX.o ${OUT}/DRAWPT.o ${OUT}/D01GBFA.o ${OUT}/D02EJFA.o \ ${OUT}/D03FAFA.o ${OUT}/FAMR.o ${OUT}/FAMR-.o ${OUT}/FLASORT.o \ @@ -2336,6 +2337,18 @@ LAYER7=\ /*"BFUNCT" -> {"EUCDOM-"; "UFD-"; "GCDDOM-"; "DIVRING-"; "INTDOM-"}*/ /*"BFUNCT" -> {"ALGEBRA-"; "DIFRING-"; "ORDRING-"; "INT"}*/ +"BLAS1" [color="#FF4488",href="bookvol10.5.pdf#nameddest=BLAS1"] +/*"BLAS1" -> {"FPS" "RNS"}*/ +"BLAS1" -> "FIELD" +/*"BLAS1" -> {"EUCDOM" "PID" "GCDDOM" "INTDOM" "COMRING" "RING" "RNG"}*/ +/*"BLAS1" -> {"ABELGRP" "CABMON" "ABELMON" "ABELSG" "SETCAT" "BASTYPE"}*/ +/*"BLAS1" -> {"KOERCE" "SGROUP" "MONOID" "LMODULE" "BMODULE" "RMODULE"}*/ +/*"BLAS1" -> {"ALGEBRA" "MODULE" "ENTIRER" "UFD" "DIVRING" "ORDRING"}*/ +/*"BLAS1" -> {"OAGROUP" "OCAMON" "OAMON" "OASGP" "ORDSET" "REAL"}*/ +/*"BLAS1" -> {"KONVERT" "RETRACT"}*/ +"BLAS1" -> "RADCAT" +/*"BLAS1" -> {"PATMAB" "CHARZ"}*/ + "BPADIC" [color="#88FF44",href="bookvol10.3.pdf#nameddest=BPADIC"] /*"BPADIC" -> "BOOLEAN"*/ "BPADIC" -> "PADICCT" diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index d07a4cf..3698062 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -2605,5 +2605,7 @@ faq FAQ 52: Who was User?
readme add Nelson Beebe and Steve Toleque to credits
20100401.03.tpd.patch books/bookvol4 document steps for adding algebra
+20100402.01.tpd.patch +books/bookvol10.5 add Volume 10.5 Axiom Numerics
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 1cc7e62..b35bd8a 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -155,7 +155,7 @@ OBJS= ${OUT}/vmlisp.${O} \ ${OUT}/i-code.${O} ${OUT}/i-coerce.${O} \ ${OUT}/i-coerfn.${O} ${OUT}/i-eval.${O} \ ${OUT}/i-funsel.${O} ${OUT}/bookvol5.${O} \ - ${OUT}/bookvol9.${O} \ + ${OUT}/bookvol9.${O} ${OUT}/bookvol10.5.${O}\ ${OUT}/i-intern.${O} ${OUT}/i-map.${O} \ ${OUT}/i-output.${O} ${OUT}/i-resolv.${O} \ ${OUT}/i-spec1.${O} \ @@ -2279,6 +2279,38 @@ ${MID}/bookvol9.${LISP}: ${IN}/bookvol9.pamphlet ${TANGLE} -RCompiler ${IN}/bookvol9.pamphlet >bookvol9.${LISP} ) @ +\subsection{bookvol10.5.lsp} +<>= +${OUT}/bookvol10.5.${O}: ${MID}/bookvol10.5.${LISP} + @ echo 297 making ${OUT}/bookvol10.5.${O} from \ + ${MID}/bookvol10.5.${LISP} + @ (cd ${MID} ; \ + if [ -z "${NOISE}" ] ; then \ + echo '(progn (compile-file "${MID}/bookvol10.5.${LISP}"' \ + ':output-file "${OUT}/bookvol10.5.${O}") (${BYE}))'\ + | ${DEPSYS} ; \ + else \ + echo '(progn (compile-file "${MID}/bookvol10.5.${LISP}"' \ + ':output-file "${OUT}/bookvol10.5.${O}") (${BYE}))' | ${DEPSYS} \ + >${TMP}/trace ; \ + fi ) + +@ +<>= +${OUT}/bookvol10.5.${LISP}: ${MID}/bookvol10.5.${LISP} + @ echo 133 making ${OUT}/bookvol10.5.${LISP} from \ + ${MID}/bookvol10.5.${LISP} + @cp ${MID}/bookvol10.5.${LISP} ${OUT}/bookvol10.5.${LISP} + +@ +<>= +${MID}/bookvol10.5.${LISP}: ${IN}/bookvol10.5.pamphlet + @ echo 298 making ${MID}/bookvol10.5.${LISP} from ${IN}/bookvol10.5.pamphlet + @ (cd ${MID} ; \ + ${TANGLE} -RNumerics ${IN}/bookvol10.5.pamphlet \ + >bookvol10.5.${LISP} ) + +@ \subsection{i-intern.lisp} <>= ${OUT}/i-intern.${O}: ${MID}/i-intern.lisp @@ -3668,6 +3700,10 @@ clean: <> <> +<> +<> +<> + <> <>