math-utils/BLAS
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Created separate directories for single and double precision. Translated and debugged all files needed to successfully compile single precision complex library. CMake files reflect necessary changes.

Browse source
This commit is contained in:
Adam Parler 2023-12-09 03:03:42 -08:00
parent 324eaf0cdc
commit a1faeb7194
77 changed files with 10525 additions and 8436 deletions
Download patch file Download diff file Expand all files Collapse all files

12
.gitignore vendored
View file

@ -1,2 +1,10 @@
.vscode/*
build/*
.vscode
bin
build
/include
lib
*.o
*.obj
*.so
*.a
*.la

9
CMakeLists.txt
View file

@ -2,14 +2,17 @@ cmake_minimum_required(VERSION 3.12)
project(BLAS C)
set(BLAS_MAJOR_VERSION 3)
set(BLAS_MINOR_VERSION 12)
set(BLAS_MAJOR_VERSION 0)
set(BLAS_MINOR_VERSION 1)
set(BLAS_PATCH_VERSION 0)
set(
BLAS_VERSION
${BLAS_MAJOR_VERSION}.${BLAS_MINOR_VERSION}.${BLAS_PATCH_VERSION}
)
set(CMAKE_C_STANDARD 99)
set(CMAKE_C_STANDARD_REQUIRED True)
# Add the CMake directory for custom CMake modules
set(CMAKE_MODULE_PATH "${BLAS_SOURCE_DIR}/cmake" ${CMAKE_MODULE_PATH})
@ -80,6 +83,8 @@ message(STATUS "Build double precision real: ${BUILD_DOUBLE}")
message(STATUS "Build single precision complex: ${BUILD_COMPLEX}")
message(STATUS "Build double precision complex: ${BUILD_COMPLEX16}")
include_directories(src/)
if(NOT (BUILD_SINGLE OR BUILD_DOUBLE OR BUILD_COMPLEX OR BUILD_COMPLEX16))
message(FATAL_ERROR "Nothing to build, no precision selected.
Please enable at least one of these:

17
src/CMakeLists.txt
View file

@ -9,6 +9,8 @@
add_subdirectory(double)
add_subdirectory(single)
add_compile_options(-fPIC -Wall -Wextra -Wpedantic -lm -O3 -march=native -mtune=native)
#---------------------------------------------------------------------
# Auxiliary routines needed by both the Level 2 and Level 3 BLAS
#---------------------------------------------------------------------
@ -22,10 +24,10 @@ if(BUILD_DOUBLE)
list(APPEND SOURCES ${DBLAS1} ${ALLBLAS} ${DBLAS2} ${DBLAS3})
endif()
if(BUILD_COMPLEX)
list(APPEND SOURCES ${CBLAS1} ${CB1AUX} ${ALLBLAS} ${CBLAS2} ${CBLAS3})
list(APPEND SOURCES abssq.c ${CBLAS1} ${CB1AUX} ${ALLBLAS} ${CBLAS2} ${CBLAS3})
endif()
if(BUILD_COMPLEX16)
list(APPEND SOURCES ${ZBLAS1} ${ZB1AUX} ${ALLBLAS} ${ZBLAS2} ${ZBLAS3})
list(APPEND SOURCES abssq.c ${ZBLAS1} ${ZB1AUX} ${ALLBLAS} ${ZBLAS2} ${ZBLAS3})
endif()
list(REMOVE_DUPLICATES SOURCES)
@ -36,4 +38,13 @@ set_target_properties(
SOVERSION ${BLAS_MAJOR_VERSION}
)
blas_install_library(${BLASLIB})
blas_install_library(${BLASLIB})
add_custom_command(
OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/generated_header.h
COMMAND ${CMAKE_COMMAND} -E echo "#define SOME_VALUE 123" > ${CMAKE_CURRENT_BINARY_DIR}/generated_header.h
COMMENT "Generating header file..."
)
# Add the generated file to the list of sources
set(SOURCES ${SOURCES} ${CMAKE_CURRENT_BINARY_DIR}/generated_header.h)

11
src/abssq.c Normal file
View file

@ -0,0 +1,11 @@
#include <math.h>
#include <complex.h>
/*
DOCUMENTATION HERE
*/
float abssq(complex float t) {
return powf(creal(t), 2) + powf(cimag(t), 2);
}

21
src/blas_internal.h Normal file
View file

@ -0,0 +1,21 @@
#ifndef _BLAS_INTERNAL_H
#define _BLAS_INTERNAL_H
// #include "errquit.h"
#include <complex.h>
#include <stdbool.h>
float abssq(complex float t);
bool lsame(char, char);
float scabs1(complex float z);
void xerbla_array(char*, int , int);
void xerbla(char* , int);
double complex complex_multiply(double complex a, double complex b) {
return (double complex)(creal(a) * creal(b) - cimag(a) * cimag(b) +
creal(a) * cimag(b) + cimag(a) * creal(b));
}
#endif // _BLAS_INTERNAL_H

387
src/cgbmv.c
View file

@ -1,387 +0,0 @@
*> \brief \b CGBMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA,BETA
* INTEGER INCX,INCY,KL,KU,LDA,M,N
* CHARACTER TRANS
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CGBMV performs one of the matrix-vector operations
*>
*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or
*>
*> y := alpha*A**H*x + beta*y,
*>
*> where alpha and beta are scalars, x and y are vectors and A is an
*> m by n band matrix, with kl sub-diagonals and ku super-diagonals.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS 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**T*x + beta*y.
*>
*> TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of the matrix A.
*> M must be at least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*> KL is INTEGER
*> On entry, KL specifies the number of sub-diagonals of the
*> matrix A. KL must satisfy 0 .le. KL.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> On entry, KU specifies the number of super-diagonals of the
*> matrix A. KU must satisfy 0 .le. KU.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, N )
*> Before entry, the leading ( kl + ku + 1 ) by n part of the
*> array A must contain the matrix of coefficients, supplied
*> column by column, with the leading diagonal of the matrix in
*> row ( ku + 1 ) of the array, the first super-diagonal
*> starting at position 2 in row ku, the first sub-diagonal
*> starting at position 1 in row ( ku + 2 ), and so on.
*> Elements in the array A that do not correspond to elements
*> in the band matrix (such as the top left ku by ku triangle)
*> are not referenced.
*> The following program segment will transfer a band matrix
*> from conventional full matrix storage to band storage:
*>
*> DO 20, J = 1, N
*> K = KU + 1 - J
*> DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL )
*> A( K + I, J ) = matrix( I, J )
*> 10 CONTINUE
*> 20 CONTINUE
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> ( kl + ku + 1 ).
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX array, 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.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is COMPLEX
*> On entry, BETA specifies the scalar beta. When BETA is
*> supplied as zero then Y need not be set on input.
*> \endverbatim
*>
*> \param[in,out] Y
*> \verbatim
*> Y is COMPLEX array, dimension at least
*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
*> and at least
*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
*> Before entry, the incremented array Y must contain the
*> vector y. On exit, Y is overwritten by the updated vector y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA,BETA
INTEGER INCX,INCY,KL,KU,LDA,M,N
CHARACTER TRANS
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ONE
PARAMETER (ONE= (1.0E+0,0.0E+0))
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
* .. Local Scalars ..
COMPLEX TEMP
INTEGER I,INFO,IX,IY,J,JX,JY,K,KUP1,KX,KY,LENX,LENY
LOGICAL NOCONJ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,MAX,MIN
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ .NOT.LSAME(TRANS,'C')) THEN
INFO = 1
ELSE IF (M.LT.0) THEN
INFO = 2
ELSE IF (N.LT.0) THEN
INFO = 3
ELSE IF (KL.LT.0) THEN
INFO = 4
ELSE IF (KU.LT.0) THEN
INFO = 5
ELSE IF (LDA.LT. (KL+KU+1)) THEN
INFO = 8
ELSE IF (INCX.EQ.0) THEN
INFO = 10
ELSE IF (INCY.EQ.0) THEN
INFO = 13
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CGBMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+ ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
NOCONJ = LSAME(TRANS,'T')
*
* Set LENX and LENY, the lengths of the vectors x and y, and set
* up the start points in X and Y.
*
IF (LSAME(TRANS,'N')) THEN
LENX = N
LENY = M
ELSE
LENX = M
LENY = N
END IF
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (LENX-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (LENY-1)*INCY
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through the band part of A.
*
* First form y := beta*y.
*
IF (BETA.NE.ONE) THEN
IF (INCY.EQ.1) THEN
IF (BETA.EQ.ZERO) THEN
DO 10 I = 1,LENY
Y(I) = ZERO
10 CONTINUE
ELSE
DO 20 I = 1,LENY
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
ELSE
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30 I = 1,LENY
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40 I = 1,LENY
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF (ALPHA.EQ.ZERO) RETURN
KUP1 = KU + 1
IF (LSAME(TRANS,'N')) THEN
*
* Form y := alpha*A*x + y.
*
JX = KX
IF (INCY.EQ.1) THEN
DO 60 J = 1,N
TEMP = ALPHA*X(JX)
K = KUP1 - J
DO 50 I = MAX(1,J-KU),MIN(M,J+KL)
Y(I) = Y(I) + TEMP*A(K+I,J)
50 CONTINUE
JX = JX + INCX
60 CONTINUE
ELSE
DO 80 J = 1,N
TEMP = ALPHA*X(JX)
IY = KY
K = KUP1 - J
DO 70 I = MAX(1,J-KU),MIN(M,J+KL)
Y(IY) = Y(IY) + TEMP*A(K+I,J)
IY = IY + INCY
70 CONTINUE
JX = JX + INCX
IF (J.GT.KU) KY = KY + INCY
80 CONTINUE
END IF
ELSE
*
* Form y := alpha*A**T*x + y or y := alpha*A**H*x + y.
*
JY = KY
IF (INCX.EQ.1) THEN
DO 110 J = 1,N
TEMP = ZERO
K = KUP1 - J
IF (NOCONJ) THEN
DO 90 I = MAX(1,J-KU),MIN(M,J+KL)
TEMP = TEMP + A(K+I,J)*X(I)
90 CONTINUE
ELSE
DO 100 I = MAX(1,J-KU),MIN(M,J+KL)
TEMP = TEMP + CONJG(A(K+I,J))*X(I)
100 CONTINUE
END IF
Y(JY) = Y(JY) + ALPHA*TEMP
JY = JY + INCY
110 CONTINUE
ELSE
DO 140 J = 1,N
TEMP = ZERO
IX = KX
K = KUP1 - J
IF (NOCONJ) THEN
DO 120 I = MAX(1,J-KU),MIN(M,J+KL)
TEMP = TEMP + A(K+I,J)*X(IX)
IX = IX + INCX
120 CONTINUE
ELSE
DO 130 I = MAX(1,J-KU),MIN(M,J+KL)
TEMP = TEMP + CONJG(A(K+I,J))*X(IX)
IX = IX + INCX
130 CONTINUE
END IF
Y(JY) = Y(JY) + ALPHA*TEMP
JY = JY + INCY
IF (J.GT.KU) KX = KX + INCX
140 CONTINUE
END IF
END IF
*
RETURN
*
* End of CGBMV
*
END

334
src/chemv.c
View file

@ -1,334 +0,0 @@
*> \brief \b CHEMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA,BETA
* INTEGER INCX,INCY,LDA,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHEMV 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 hermitian matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> 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.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, N )
*> 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 hermitian 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 hermitian matrix and the strictly
*> upper triangular part of A is not referenced.
*> Note that the imaginary parts of the diagonal elements need
*> not be set and are assumed to be zero.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> max( 1, n ).
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is COMPLEX
*> On entry, BETA specifies the scalar beta. When BETA is
*> supplied as zero then Y need not be set on input.
*> \endverbatim
*>
*> \param[in,out] Y
*> \verbatim
*> Y is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCY ) ).
*> Before entry, the incremented array Y must contain the n
*> element vector y. On exit, Y is overwritten by the updated
*> vector y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA,BETA
INTEGER INCX,INCY,LDA,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ONE
PARAMETER (ONE= (1.0E+0,0.0E+0))
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
* .. Local Scalars ..
COMPLEX TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,MAX,REAL
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (N.LT.0) THEN
INFO = 2
ELSE IF (LDA.LT.MAX(1,N)) THEN
INFO = 5
ELSE IF (INCX.EQ.0) THEN
INFO = 7
ELSE IF (INCY.EQ.0) THEN
INFO = 10
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CHEMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* Set up the start points in X and Y.
*
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (N-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (N-1)*INCY
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through the triangular part
* of A.
*
* First form y := beta*y.
*
IF (BETA.NE.ONE) THEN
IF (INCY.EQ.1) THEN
IF (BETA.EQ.ZERO) THEN
DO 10 I = 1,N
Y(I) = ZERO
10 CONTINUE
ELSE
DO 20 I = 1,N
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
ELSE
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30 I = 1,N
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40 I = 1,N
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF (ALPHA.EQ.ZERO) RETURN
IF (LSAME(UPLO,'U')) THEN
*
* Form y when A is stored in upper triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
DO 50 I = 1,J - 1
Y(I) = Y(I) + TEMP1*A(I,J)
TEMP2 = TEMP2 + CONJG(A(I,J))*X(I)
50 CONTINUE
Y(J) = Y(J) + TEMP1*REAL(A(J,J)) + ALPHA*TEMP2
60 CONTINUE
ELSE
JX = KX
JY = KY
DO 80 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
IX = KX
IY = KY
DO 70 I = 1,J - 1
Y(IY) = Y(IY) + TEMP1*A(I,J)
TEMP2 = TEMP2 + CONJG(A(I,J))*X(IX)
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y(JY) = Y(JY) + TEMP1*REAL(A(J,J)) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
80 CONTINUE
END IF
ELSE
*
* Form y when A is stored in lower triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 100 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
Y(J) = Y(J) + TEMP1*REAL(A(J,J))
DO 90 I = J + 1,N
Y(I) = Y(I) + TEMP1*A(I,J)
TEMP2 = TEMP2 + CONJG(A(I,J))*X(I)
90 CONTINUE
Y(J) = Y(J) + ALPHA*TEMP2
100 CONTINUE
ELSE
JX = KX
JY = KY
DO 120 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
Y(JY) = Y(JY) + TEMP1*REAL(A(J,J))
IX = JX
IY = JY
DO 110 I = J + 1,N
IX = IX + INCX
IY = IY + INCY
Y(IY) = Y(IY) + TEMP1*A(I,J)
TEMP2 = TEMP2 + CONJG(A(I,J))*X(IX)
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of CHEMV
*
END

275
src/cher.c
View file

@ -1,275 +0,0 @@
*> \brief \b CHER
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHER(UPLO,N,ALPHA,X,INCX,A,LDA)
*
* .. Scalar Arguments ..
* REAL ALPHA
* INTEGER INCX,LDA,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHER performs the hermitian rank 1 operation
*>
*> A := alpha*x*x**H + A,
*>
*> where alpha is a real scalar, x is an n element vector and A is an
*> n by n hermitian matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> 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.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is REAL
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, N )
*> 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 hermitian 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 hermitian 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.
*> Note that the imaginary parts of the diagonal elements need
*> not be set, they are assumed to be zero, and on exit they
*> are set to zero.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> max( 1, n ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CHER(UPLO,N,ALPHA,X,INCX,A,LDA)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
REAL ALPHA
INTEGER INCX,LDA,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),X(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
* .. Local Scalars ..
COMPLEX TEMP
INTEGER I,INFO,IX,J,JX,KX
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,MAX,REAL
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (N.LT.0) THEN
INFO = 2
ELSE IF (INCX.EQ.0) THEN
INFO = 5
ELSE IF (LDA.LT.MAX(1,N)) THEN
INFO = 7
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CHER ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (ALPHA.EQ.REAL(ZERO))) RETURN
*
* Set the start point in X if the increment is not unity.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through the triangular part
* of A.
*
IF (LSAME(UPLO,'U')) THEN
*
* Form A when A is stored in upper triangle.
*
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*CONJG(X(J))
DO 10 I = 1,J - 1
A(I,J) = A(I,J) + X(I)*TEMP
10 CONTINUE
A(J,J) = REAL(A(J,J)) + REAL(X(J)*TEMP)
ELSE
A(J,J) = REAL(A(J,J))
END IF
20 CONTINUE
ELSE
JX = KX
DO 40 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*CONJG(X(JX))
IX = KX
DO 30 I = 1,J - 1
A(I,J) = A(I,J) + X(IX)*TEMP
IX = IX + INCX
30 CONTINUE
A(J,J) = REAL(A(J,J)) + REAL(X(JX)*TEMP)
ELSE
A(J,J) = REAL(A(J,J))
END IF
JX = JX + INCX
40 CONTINUE
END IF
ELSE
*
* Form A when A is stored in lower triangle.
*
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*CONJG(X(J))
A(J,J) = REAL(A(J,J)) + REAL(TEMP*X(J))
DO 50 I = J + 1,N
A(I,J) = A(I,J) + X(I)*TEMP
50 CONTINUE
ELSE
A(J,J) = REAL(A(J,J))
END IF
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*CONJG(X(JX))
A(J,J) = REAL(A(J,J)) + REAL(TEMP*X(JX))
IX = JX
DO 70 I = J + 1,N
IX = IX + INCX
A(I,J) = A(I,J) + X(IX)*TEMP
70 CONTINUE
ELSE
A(J,J) = REAL(A(J,J))
END IF
JX = JX + INCX
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of CHER
*
END

314
src/cher2.c
View file

@ -1,314 +0,0 @@
*> \brief \b CHER2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA
* INTEGER INCX,INCY,LDA,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHER2 performs the hermitian rank 2 operation
*>
*> A := alpha*x*y**H + conjg( alpha )*y*x**H + A,
*>
*> where alpha is a scalar, x and y are n element vectors and A is an n
*> by n hermitian matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> 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.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCY ) ).
*> Before entry, the incremented array Y must contain the n
*> element vector y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, N )
*> 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 hermitian 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 hermitian 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.
*> Note that the imaginary parts of the diagonal elements need
*> not be set, they are assumed to be zero, and on exit they
*> are set to zero.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> max( 1, n ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA
INTEGER INCX,INCY,LDA,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
* .. Local Scalars ..
COMPLEX TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,MAX,REAL
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (N.LT.0) THEN
INFO = 2
ELSE IF (INCX.EQ.0) THEN
INFO = 5
ELSE IF (INCY.EQ.0) THEN
INFO = 7
ELSE IF (LDA.LT.MAX(1,N)) THEN
INFO = 9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CHER2 ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
*
* Set up the start points in X and Y if the increments are not both
* unity.
*
IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (N-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (N-1)*INCY
END IF
JX = KX
JY = KY
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through the triangular part
* of A.
*
IF (LSAME(UPLO,'U')) THEN
*
* Form A when A is stored in the upper triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 20 J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*CONJG(Y(J))
TEMP2 = CONJG(ALPHA*X(J))
DO 10 I = 1,J - 1
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
10 CONTINUE
A(J,J) = REAL(A(J,J)) +
+ REAL(X(J)*TEMP1+Y(J)*TEMP2)
ELSE
A(J,J) = REAL(A(J,J))
END IF
20 CONTINUE
ELSE
DO 40 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*CONJG(Y(JY))
TEMP2 = CONJG(ALPHA*X(JX))
IX = KX
IY = KY
DO 30 I = 1,J - 1
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
30 CONTINUE
A(J,J) = REAL(A(J,J)) +
+ REAL(X(JX)*TEMP1+Y(JY)*TEMP2)
ELSE
A(J,J) = REAL(A(J,J))
END IF
JX = JX + INCX
JY = JY + INCY
40 CONTINUE
END IF
ELSE
*
* Form A when A is stored in the lower triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60 J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*CONJG(Y(J))
TEMP2 = CONJG(ALPHA*X(J))
A(J,J) = REAL(A(J,J)) +
+ REAL(X(J)*TEMP1+Y(J)*TEMP2)
DO 50 I = J + 1,N
A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
50 CONTINUE
ELSE
A(J,J) = REAL(A(J,J))
END IF
60 CONTINUE
ELSE
DO 80 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*CONJG(Y(JY))
TEMP2 = CONJG(ALPHA*X(JX))
A(J,J) = REAL(A(J,J)) +
+ REAL(X(JX)*TEMP1+Y(JY)*TEMP2)
IX = JX
IY = JY
DO 70 I = J + 1,N
IX = IX + INCX
IY = IY + INCY
A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
70 CONTINUE
ELSE
A(J,J) = REAL(A(J,J))
END IF
JX = JX + INCX
JY = JY + INCY
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of CHER2
*
END

439
src/cher2k.c
View file

@ -1,439 +0,0 @@
*> \brief \b CHER2K
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA
* REAL BETA
* INTEGER K,LDA,LDB,LDC,N
* CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHER2K performs one of the hermitian rank 2k operations
*>
*> C := alpha*A*B**H + conjg( alpha )*B*A**H + beta*C,
*>
*> or
*>
*> C := alpha*A**H*B + conjg( alpha )*B**H*A + beta*C,
*>
*> where alpha and beta are scalars with beta real, C is an n by n
*> hermitian matrix and A and B are n by k matrices in the first case
*> and k by n matrices in the second case.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO 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.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' C := alpha*A*B**H +
*> conjg( alpha )*B*A**H +
*> beta*C.
*>
*> TRANS = 'C' or 'c' C := alpha*A**H*B +
*> conjg( alpha )*B**H*A +
*> beta*C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix C. N must be
*> at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> On entry with TRANS = 'N' or 'n', K specifies the number
*> of columns of the matrices A and B, and on entry with
*> TRANS = 'C' or 'c', K specifies the number of rows of the
*> matrices A and B. K must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, ka ), where ka is
*> k when TRANS = 'N' or 'n', and is n otherwise.
*> 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.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA 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 ).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is COMPLEX array, dimension ( LDB, kb ), where kb is
*> k when TRANS = 'N' or 'n', and is n otherwise.
*> 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.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> On entry, LDB 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 ).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is REAL
*> On entry, BETA specifies the scalar beta.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX array, dimension ( LDC, N )
*> 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 hermitian 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 hermitian 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.
*> Note that the imaginary parts of the diagonal elements need
*> not be set, they are assumed to be zero, and on exit they
*> are set to zero.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> On entry, LDC specifies the first dimension of C as declared
*> in the calling (sub) program. LDC must be at least
*> max( 1, n ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level3
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 3 Blas routine.
*>
*> -- Written on 8-February-1989.
*> Jack Dongarra, Argonne National Laboratory.
*> Iain Duff, AERE Harwell.
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
*> Sven Hammarling, Numerical Algorithms Group Ltd.
*>
*> -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1.
*> Ed Anderson, Cray Research Inc.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* -- Reference BLAS level3 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA
REAL BETA
INTEGER K,LDA,LDB,LDC,N
CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,MAX,REAL
* ..
* .. Local Scalars ..
COMPLEX TEMP1,TEMP2
INTEGER I,INFO,J,L,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
REAL ONE
PARAMETER (ONE=1.0E+0)
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
*
* Test the input parameters.
*
IF (LSAME(TRANS,'N')) THEN
NROWA = N
ELSE
NROWA = K
END IF
UPPER = LSAME(UPLO,'U')
*
INFO = 0
IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
INFO = 1
ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
+ (.NOT.LSAME(TRANS,'C'))) THEN
INFO = 2
ELSE IF (N.LT.0) THEN
INFO = 3
ELSE IF (K.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 7
ELSE IF (LDB.LT.MAX(1,NROWA)) THEN
INFO = 9
ELSE IF (LDC.LT.MAX(1,N)) THEN
INFO = 12
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CHER2K',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
+ (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
*
* And when alpha.eq.zero.
*
IF (ALPHA.EQ.ZERO) THEN
IF (UPPER) THEN
IF (BETA.EQ.REAL(ZERO)) THEN
DO 20 J = 1,N
DO 10 I = 1,J
C(I,J) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1,N
DO 30 I = 1,J - 1
C(I,J) = BETA*C(I,J)
30 CONTINUE
C(J,J) = BETA*REAL(C(J,J))
40 CONTINUE
END IF
ELSE
IF (BETA.EQ.REAL(ZERO)) THEN
DO 60 J = 1,N
DO 50 I = J,N
C(I,J) = ZERO
50 CONTINUE
60 CONTINUE
ELSE
DO 80 J = 1,N
C(J,J) = BETA*REAL(C(J,J))
DO 70 I = J + 1,N
C(I,J) = BETA*C(I,J)
70 CONTINUE
80 CONTINUE
END IF
END IF
RETURN
END IF
*
* Start the operations.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form C := alpha*A*B**H + conjg( alpha )*B*A**H +
* C.
*
IF (UPPER) THEN
DO 130 J = 1,N
IF (BETA.EQ.REAL(ZERO)) THEN
DO 90 I = 1,J
C(I,J) = ZERO
90 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 100 I = 1,J - 1
C(I,J) = BETA*C(I,J)
100 CONTINUE
C(J,J) = BETA*REAL(C(J,J))
ELSE
C(J,J) = REAL(C(J,J))
END IF
DO 120 L = 1,K
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
TEMP1 = ALPHA*CONJG(B(J,L))
TEMP2 = CONJG(ALPHA*A(J,L))
DO 110 I = 1,J - 1
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
+ B(I,L)*TEMP2
110 CONTINUE
C(J,J) = REAL(C(J,J)) +
+ REAL(A(J,L)*TEMP1+B(J,L)*TEMP2)
END IF
120 CONTINUE
130 CONTINUE
ELSE
DO 180 J = 1,N
IF (BETA.EQ.REAL(ZERO)) THEN
DO 140 I = J,N
C(I,J) = ZERO
140 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 150 I = J + 1,N
C(I,J) = BETA*C(I,J)
150 CONTINUE
C(J,J) = BETA*REAL(C(J,J))
ELSE
C(J,J) = REAL(C(J,J))
END IF
DO 170 L = 1,K
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
TEMP1 = ALPHA*CONJG(B(J,L))
TEMP2 = CONJG(ALPHA*A(J,L))
DO 160 I = J + 1,N
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
+ B(I,L)*TEMP2
160 CONTINUE
C(J,J) = REAL(C(J,J)) +
+ REAL(A(J,L)*TEMP1+B(J,L)*TEMP2)
END IF
170 CONTINUE
180 CONTINUE
END IF
ELSE
*
* Form C := alpha*A**H*B + conjg( alpha )*B**H*A +
* C.
*
IF (UPPER) THEN
DO 210 J = 1,N
DO 200 I = 1,J
TEMP1 = ZERO
TEMP2 = ZERO
DO 190 L = 1,K
TEMP1 = TEMP1 + CONJG(A(L,I))*B(L,J)
TEMP2 = TEMP2 + CONJG(B(L,I))*A(L,J)
190 CONTINUE
IF (I.EQ.J) THEN
IF (BETA.EQ.REAL(ZERO)) THEN
C(J,J) = REAL(ALPHA*TEMP1+
+ CONJG(ALPHA)*TEMP2)
ELSE
C(J,J) = BETA*REAL(C(J,J)) +
+ REAL(ALPHA*TEMP1+
+ CONJG(ALPHA)*TEMP2)
END IF
ELSE
IF (BETA.EQ.REAL(ZERO)) THEN
C(I,J) = ALPHA*TEMP1 + CONJG(ALPHA)*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+ CONJG(ALPHA)*TEMP2
END IF
END IF
200 CONTINUE
210 CONTINUE
ELSE
DO 240 J = 1,N
DO 230 I = J,N
TEMP1 = ZERO
TEMP2 = ZERO
DO 220 L = 1,K
TEMP1 = TEMP1 + CONJG(A(L,I))*B(L,J)
TEMP2 = TEMP2 + CONJG(B(L,I))*A(L,J)
220 CONTINUE
IF (I.EQ.J) THEN
IF (BETA.EQ.REAL(ZERO)) THEN
C(J,J) = REAL(ALPHA*TEMP1+
+ CONJG(ALPHA)*TEMP2)
ELSE
C(J,J) = BETA*REAL(C(J,J)) +
+ REAL(ALPHA*TEMP1+
+ CONJG(ALPHA)*TEMP2)
END IF
ELSE
IF (BETA.EQ.REAL(ZERO)) THEN
C(I,J) = ALPHA*TEMP1 + CONJG(ALPHA)*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+ CONJG(ALPHA)*TEMP2
END IF
END IF
230 CONTINUE
240 CONTINUE
END IF
END IF
*
RETURN
*
* End of CHER2K
*
END

393
src/cherk.c
View file

@ -1,393 +0,0 @@
*> \brief \b CHERK
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
*
* .. Scalar Arguments ..
* REAL ALPHA,BETA
* INTEGER K,LDA,LDC,N
* CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHERK performs one of the hermitian rank k operations
*>
*> C := alpha*A*A**H + beta*C,
*>
*> or
*>
*> C := alpha*A**H*A + beta*C,
*>
*> where alpha and beta are real scalars, C is an n by n hermitian
*> matrix and A is an n by k matrix in the first case and a k by n
*> matrix in the second case.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO 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.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' C := alpha*A*A**H + beta*C.
*>
*> TRANS = 'C' or 'c' C := alpha*A**H*A + beta*C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix C. N must be
*> at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> On entry with TRANS = 'N' or 'n', K specifies the number
*> of columns of the matrix A, and on entry with
*> TRANS = 'C' or 'c', K specifies the number of rows of the
*> matrix A. K must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is REAL
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, ka ), where ka is
*> k when TRANS = 'N' or 'n', and is n otherwise.
*> 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.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA 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 ).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is REAL
*> On entry, BETA specifies the scalar beta.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX array, dimension ( LDC, N )
*> 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 hermitian 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 hermitian 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.
*> Note that the imaginary parts of the diagonal elements need
*> not be set, they are assumed to be zero, and on exit they
*> are set to zero.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> On entry, LDC specifies the first dimension of C as declared
*> in the calling (sub) program. LDC must be at least
*> max( 1, n ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level3
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 3 Blas routine.
*>
*> -- Written on 8-February-1989.
*> Jack Dongarra, Argonne National Laboratory.
*> Iain Duff, AERE Harwell.
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
*> Sven Hammarling, Numerical Algorithms Group Ltd.
*>
*> -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1.
*> Ed Anderson, Cray Research Inc.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
*
* -- Reference BLAS level3 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
REAL ALPHA,BETA
INTEGER K,LDA,LDC,N
CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),C(LDC,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CMPLX,CONJG,MAX,REAL
* ..
* .. Local Scalars ..
COMPLEX TEMP
REAL RTEMP
INTEGER I,INFO,J,L,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
REAL ONE,ZERO
PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
* ..
*
* Test the input parameters.
*
IF (LSAME(TRANS,'N')) THEN
NROWA = N
ELSE
NROWA = K
END IF
UPPER = LSAME(UPLO,'U')
*
INFO = 0
IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
INFO = 1
ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
+ (.NOT.LSAME(TRANS,'C'))) THEN
INFO = 2
ELSE IF (N.LT.0) THEN
INFO = 3
ELSE IF (K.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 7
ELSE IF (LDC.LT.MAX(1,N)) THEN
INFO = 10
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CHERK ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
+ (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
*
* And when alpha.eq.zero.
*
IF (ALPHA.EQ.ZERO) THEN
IF (UPPER) THEN
IF (BETA.EQ.ZERO) THEN
DO 20 J = 1,N
DO 10 I = 1,J
C(I,J) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1,N
DO 30 I = 1,J - 1
C(I,J) = BETA*C(I,J)
30 CONTINUE
C(J,J) = BETA*REAL(C(J,J))
40 CONTINUE
END IF
ELSE
IF (BETA.EQ.ZERO) THEN
DO 60 J = 1,N
DO 50 I = J,N
C(I,J) = ZERO
50 CONTINUE
60 CONTINUE
ELSE
DO 80 J = 1,N
C(J,J) = BETA*REAL(C(J,J))
DO 70 I = J + 1,N
C(I,J) = BETA*C(I,J)
70 CONTINUE
80 CONTINUE
END IF
END IF
RETURN
END IF
*
* Start the operations.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form C := alpha*A*A**H + beta*C.
*
IF (UPPER) THEN
DO 130 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 90 I = 1,J
C(I,J) = ZERO
90 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 100 I = 1,J - 1
C(I,J) = BETA*C(I,J)
100 CONTINUE
C(J,J) = BETA*REAL(C(J,J))
ELSE
C(J,J) = REAL(C(J,J))
END IF
DO 120 L = 1,K
IF (A(J,L).NE.CMPLX(ZERO)) THEN
TEMP = ALPHA*CONJG(A(J,L))
DO 110 I = 1,J - 1
C(I,J) = C(I,J) + TEMP*A(I,L)
110 CONTINUE
C(J,J) = REAL(C(J,J)) + REAL(TEMP*A(I,L))
END IF
120 CONTINUE
130 CONTINUE
ELSE
DO 180 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 140 I = J,N
C(I,J) = ZERO
140 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
C(J,J) = BETA*REAL(C(J,J))
DO 150 I = J + 1,N
C(I,J) = BETA*C(I,J)
150 CONTINUE
ELSE
C(J,J) = REAL(C(J,J))
END IF
DO 170 L = 1,K
IF (A(J,L).NE.CMPLX(ZERO)) THEN
TEMP = ALPHA*CONJG(A(J,L))
C(J,J) = REAL(C(J,J)) + REAL(TEMP*A(J,L))
DO 160 I = J + 1,N
C(I,J) = C(I,J) + TEMP*A(I,L)
160 CONTINUE
END IF
170 CONTINUE
180 CONTINUE
END IF
ELSE
*
* Form C := alpha*A**H*A + beta*C.
*
IF (UPPER) THEN
DO 220 J = 1,N
DO 200 I = 1,J - 1
TEMP = ZERO
DO 190 L = 1,K
TEMP = TEMP + CONJG(A(L,I))*A(L,J)
190 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
200 CONTINUE
RTEMP = ZERO
DO 210 L = 1,K
RTEMP = RTEMP + REAL(CONJG(A(L,J))*A(L,J))
210 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(J,J) = ALPHA*RTEMP
ELSE
C(J,J) = ALPHA*RTEMP + BETA*REAL(C(J,J))
END IF
220 CONTINUE
ELSE
DO 260 J = 1,N
RTEMP = ZERO
DO 230 L = 1,K
RTEMP = RTEMP + REAL(CONJG(A(L,J))*A(L,J))
230 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(J,J) = ALPHA*RTEMP
ELSE
C(J,J) = ALPHA*RTEMP + BETA*REAL(C(J,J))
END IF
DO 250 I = J + 1,N
TEMP = ZERO
DO 240 L = 1,K
TEMP = TEMP + CONJG(A(L,I))*A(L,J)
240 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
250 CONTINUE
260 CONTINUE
END IF
END IF
*
RETURN
*
* End of CHERK
*
END

335
src/chpmv.c
View file

@ -1,335 +0,0 @@
*> \brief \b CHPMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA,BETA
* INTEGER INCX,INCY,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX AP(*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHPMV 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 hermitian matrix, supplied in packed form.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the matrix A is supplied in the packed
*> array AP as follows:
*>
*> UPLO = 'U' or 'u' The upper triangular part of A is
*> supplied in AP.
*>
*> UPLO = 'L' or 'l' The lower triangular part of A is
*> supplied in AP.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is COMPLEX array, dimension at least
*> ( ( n*( n + 1 ) )/2 ).
*> Before entry with UPLO = 'U' or 'u', the array AP must
*> contain the upper triangular part of the hermitian matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
*> and a( 2, 2 ) respectively, and so on.
*> Before entry with UPLO = 'L' or 'l', the array AP must
*> contain the lower triangular part of the hermitian matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
*> and a( 3, 1 ) respectively, and so on.
*> Note that the imaginary parts of the diagonal elements need
*> not be set and are assumed to be zero.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is COMPLEX
*> On entry, BETA specifies the scalar beta. When BETA is
*> supplied as zero then Y need not be set on input.
*> \endverbatim
*>
*> \param[in,out] Y
*> \verbatim
*> Y is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCY ) ).
*> Before entry, the incremented array Y must contain the n
*> element vector y. On exit, Y is overwritten by the updated
*> vector y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA,BETA
INTEGER INCX,INCY,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
COMPLEX AP(*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ONE
PARAMETER (ONE= (1.0E+0,0.0E+0))
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
* .. Local Scalars ..
COMPLEX TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,REAL
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (N.LT.0) THEN
INFO = 2
ELSE IF (INCX.EQ.0) THEN
INFO = 6
ELSE IF (INCY.EQ.0) THEN
INFO = 9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CHPMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* Set up the start points in X and Y.
*
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (N-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (N-1)*INCY
END IF
*
* Start the operations. In this version the elements of the array AP
* are accessed sequentially with one pass through AP.
*
* First form y := beta*y.
*
IF (BETA.NE.ONE) THEN
IF (INCY.EQ.1) THEN
IF (BETA.EQ.ZERO) THEN
DO 10 I = 1,N
Y(I) = ZERO
10 CONTINUE
ELSE
DO 20 I = 1,N
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
ELSE
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30 I = 1,N
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40 I = 1,N
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF (ALPHA.EQ.ZERO) RETURN
KK = 1
IF (LSAME(UPLO,'U')) THEN
*
* Form y when AP contains the upper triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
K = KK
DO 50 I = 1,J - 1
Y(I) = Y(I) + TEMP1*AP(K)
TEMP2 = TEMP2 + CONJG(AP(K))*X(I)
K = K + 1
50 CONTINUE
Y(J) = Y(J) + TEMP1*REAL(AP(KK+J-1)) + ALPHA*TEMP2
KK = KK + J
60 CONTINUE
ELSE
JX = KX
JY = KY
DO 80 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
IX = KX
IY = KY
DO 70 K = KK,KK + J - 2
Y(IY) = Y(IY) + TEMP1*AP(K)
TEMP2 = TEMP2 + CONJG(AP(K))*X(IX)
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y(JY) = Y(JY) + TEMP1*REAL(AP(KK+J-1)) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
KK = KK + J
80 CONTINUE
END IF
ELSE
*
* Form y when AP contains the lower triangle.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 100 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
Y(J) = Y(J) + TEMP1*REAL(AP(KK))
K = KK + 1
DO 90 I = J + 1,N
Y(I) = Y(I) + TEMP1*AP(K)
TEMP2 = TEMP2 + CONJG(AP(K))*X(I)
K = K + 1
90 CONTINUE
Y(J) = Y(J) + ALPHA*TEMP2
KK = KK + (N-J+1)
100 CONTINUE
ELSE
JX = KX
JY = KY
DO 120 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
Y(JY) = Y(JY) + TEMP1*REAL(AP(KK))
IX = JX
IY = JY
DO 110 K = KK + 1,KK + N - J
IX = IX + INCX
IY = IY + INCY
Y(IY) = Y(IY) + TEMP1*AP(K)
TEMP2 = TEMP2 + CONJG(AP(K))*X(IX)
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
KK = KK + (N-J+1)
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of CHPMV
*
END

276
src/chpr.c
View file

@ -1,276 +0,0 @@
*> \brief \b CHPR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHPR(UPLO,N,ALPHA,X,INCX,AP)
*
* .. Scalar Arguments ..
* REAL ALPHA
* INTEGER INCX,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX AP(*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHPR performs the hermitian rank 1 operation
*>
*> A := alpha*x*x**H + A,
*>
*> where alpha is a real scalar, x is an n element vector and A is an
*> n by n hermitian matrix, supplied in packed form.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the matrix A is supplied in the packed
*> array AP as follows:
*>
*> UPLO = 'U' or 'u' The upper triangular part of A is
*> supplied in AP.
*>
*> UPLO = 'L' or 'l' The lower triangular part of A is
*> supplied in AP.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is REAL
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in,out] AP
*> \verbatim
*> AP is COMPLEX array, dimension at least
*> ( ( n*( n + 1 ) )/2 ).
*> Before entry with UPLO = 'U' or 'u', the array AP must
*> contain the upper triangular part of the hermitian matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
*> and a( 2, 2 ) respectively, and so on. On exit, the array
*> AP is overwritten by the upper triangular part of the
*> updated matrix.
*> Before entry with UPLO = 'L' or 'l', the array AP must
*> contain the lower triangular part of the hermitian matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
*> and a( 3, 1 ) respectively, and so on. On exit, the array
*> AP is overwritten by the lower triangular part of the
*> updated matrix.
*> Note that the imaginary parts of the diagonal elements need
*> not be set, they are assumed to be zero, and on exit they
*> are set to zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CHPR(UPLO,N,ALPHA,X,INCX,AP)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
REAL ALPHA
INTEGER INCX,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
COMPLEX AP(*),X(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
* .. Local Scalars ..
COMPLEX TEMP
INTEGER I,INFO,IX,J,JX,K,KK,KX
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,REAL
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (N.LT.0) THEN
INFO = 2
ELSE IF (INCX.EQ.0) THEN
INFO = 5
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CHPR ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (ALPHA.EQ.REAL(ZERO))) RETURN
*
* Set the start point in X if the increment is not unity.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of the array AP
* are accessed sequentially with one pass through AP.
*
KK = 1
IF (LSAME(UPLO,'U')) THEN
*
* Form A when upper triangle is stored in AP.
*
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*CONJG(X(J))
K = KK
DO 10 I = 1,J - 1
AP(K) = AP(K) + X(I)*TEMP
K = K + 1
10 CONTINUE
AP(KK+J-1) = REAL(AP(KK+J-1)) + REAL(X(J)*TEMP)
ELSE
AP(KK+J-1) = REAL(AP(KK+J-1))
END IF
KK = KK + J
20 CONTINUE
ELSE
JX = KX
DO 40 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*CONJG(X(JX))
IX = KX
DO 30 K = KK,KK + J - 2
AP(K) = AP(K) + X(IX)*TEMP
IX = IX + INCX
30 CONTINUE
AP(KK+J-1) = REAL(AP(KK+J-1)) + REAL(X(JX)*TEMP)
ELSE
AP(KK+J-1) = REAL(AP(KK+J-1))
END IF
JX = JX + INCX
KK = KK + J
40 CONTINUE
END IF
ELSE
*
* Form A when lower triangle is stored in AP.
*
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = ALPHA*CONJG(X(J))
AP(KK) = REAL(AP(KK)) + REAL(TEMP*X(J))
K = KK + 1
DO 50 I = J + 1,N
AP(K) = AP(K) + X(I)*TEMP
K = K + 1
50 CONTINUE
ELSE
AP(KK) = REAL(AP(KK))
END IF
KK = KK + N - J + 1
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = ALPHA*CONJG(X(JX))
AP(KK) = REAL(AP(KK)) + REAL(TEMP*X(JX))
IX = JX
DO 70 K = KK + 1,KK + N - J
IX = IX + INCX
AP(K) = AP(K) + X(IX)*TEMP
70 CONTINUE
ELSE
AP(KK) = REAL(AP(KK))
END IF
JX = JX + INCX
KK = KK + N - J + 1
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of CHPR
*
END

315
src/chpr2.c
View file

@ -1,315 +0,0 @@
*> \brief \b CHPR2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA
* INTEGER INCX,INCY,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX AP(*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHPR2 performs the hermitian rank 2 operation
*>
*> A := alpha*x*y**H + conjg( alpha )*y*x**H + A,
*>
*> where alpha is a scalar, x and y are n element vectors and A is an
*> n by n hermitian matrix, supplied in packed form.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the matrix A is supplied in the packed
*> array AP as follows:
*>
*> UPLO = 'U' or 'u' The upper triangular part of A is
*> supplied in AP.
*>
*> UPLO = 'L' or 'l' The lower triangular part of A is
*> supplied in AP.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCY ) ).
*> Before entry, the incremented array Y must contain the n
*> element vector y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> \endverbatim
*>
*> \param[in,out] AP
*> \verbatim
*> AP is COMPLEX array, dimension at least
*> ( ( n*( n + 1 ) )/2 ).
*> Before entry with UPLO = 'U' or 'u', the array AP must
*> contain the upper triangular part of the hermitian matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
*> and a( 2, 2 ) respectively, and so on. On exit, the array
*> AP is overwritten by the upper triangular part of the
*> updated matrix.
*> Before entry with UPLO = 'L' or 'l', the array AP must
*> contain the lower triangular part of the hermitian matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
*> and a( 3, 1 ) respectively, and so on. On exit, the array
*> AP is overwritten by the lower triangular part of the
*> updated matrix.
*> Note that the imaginary parts of the diagonal elements need
*> not be set, they are assumed to be zero, and on exit they
*> are set to zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA
INTEGER INCX,INCY,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
COMPLEX AP(*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
* .. Local Scalars ..
COMPLEX TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,REAL
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (N.LT.0) THEN
INFO = 2
ELSE IF (INCX.EQ.0) THEN
INFO = 5
ELSE IF (INCY.EQ.0) THEN
INFO = 7
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CHPR2 ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
*
* Set up the start points in X and Y if the increments are not both
* unity.
*
IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (N-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (N-1)*INCY
END IF
JX = KX
JY = KY
END IF
*
* Start the operations. In this version the elements of the array AP
* are accessed sequentially with one pass through AP.
*
KK = 1
IF (LSAME(UPLO,'U')) THEN
*
* Form A when upper triangle is stored in AP.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 20 J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*CONJG(Y(J))
TEMP2 = CONJG(ALPHA*X(J))
K = KK
DO 10 I = 1,J - 1
AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
K = K + 1
10 CONTINUE
AP(KK+J-1) = REAL(AP(KK+J-1)) +
+ REAL(X(J)*TEMP1+Y(J)*TEMP2)
ELSE
AP(KK+J-1) = REAL(AP(KK+J-1))
END IF
KK = KK + J
20 CONTINUE
ELSE
DO 40 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*CONJG(Y(JY))
TEMP2 = CONJG(ALPHA*X(JX))
IX = KX
IY = KY
DO 30 K = KK,KK + J - 2
AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
IX = IX + INCX
IY = IY + INCY
30 CONTINUE
AP(KK+J-1) = REAL(AP(KK+J-1)) +
+ REAL(X(JX)*TEMP1+Y(JY)*TEMP2)
ELSE
AP(KK+J-1) = REAL(AP(KK+J-1))
END IF
JX = JX + INCX
JY = JY + INCY
KK = KK + J
40 CONTINUE
END IF
ELSE
*
* Form A when lower triangle is stored in AP.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60 J = 1,N
IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
TEMP1 = ALPHA*CONJG(Y(J))
TEMP2 = CONJG(ALPHA*X(J))
AP(KK) = REAL(AP(KK)) +
+ REAL(X(J)*TEMP1+Y(J)*TEMP2)
K = KK + 1
DO 50 I = J + 1,N
AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
K = K + 1
50 CONTINUE
ELSE
AP(KK) = REAL(AP(KK))
END IF
KK = KK + N - J + 1
60 CONTINUE
ELSE
DO 80 J = 1,N
IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
TEMP1 = ALPHA*CONJG(Y(JY))
TEMP2 = CONJG(ALPHA*X(JX))
AP(KK) = REAL(AP(KK)) +
+ REAL(X(JX)*TEMP1+Y(JY)*TEMP2)
IX = JX
IY = JY
DO 70 K = KK + 1,KK + N - J
IX = IX + INCX
IY = IY + INCY
AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
70 CONTINUE
ELSE
AP(KK) = REAL(AP(KK))
END IF
JX = JX + INCX
JY = JY + INCY
KK = KK + N - J + 1
80 CONTINUE
END IF
END IF
*
RETURN
*
* End of CHPR2
*
END

277
src/crotg.c
View file

@ -1,277 +0,0 @@
!> \brief \b CROTG generates a Givens rotation with real cosine and complex sine.
!
! =========== DOCUMENTATION ===========
!
! Online html documentation available at
! http://www.netlib.org/lapack/explore-html/
!
! Definition:
! ===========
!
! CROTG constructs a plane rotation
! [ c s ] [ a ] = [ r ]
! [ -conjg(s) c ] [ b ] [ 0 ]
! where c is real, s is complex, and c**2 + conjg(s)*s = 1.
!
!> \par Purpose:
! =============
!>
!> \verbatim
!>
!> The computation uses the formulas
!> |x| = sqrt( Re(x)**2 + Im(x)**2 )
!> sgn(x) = x / |x| if x /= 0
!> = 1 if x = 0
!> c = |a| / sqrt(|a|**2 + |b|**2)
!> s = sgn(a) * conjg(b) / sqrt(|a|**2 + |b|**2)
!> r = sgn(a)*sqrt(|a|**2 + |b|**2)
!> When a and b are real and r /= 0, the formulas simplify to
!> c = a / r
!> s = b / r
!> the same as in SROTG when |a| > |b|. When |b| >= |a|, the
!> sign of c and s will be different from those computed by SROTG
!> if the signs of a and b are not the same.
!>
!> \endverbatim
!
! Arguments:
! ==========
!
!> \param[in,out] A
!> \verbatim
!> A is COMPLEX
!> On entry, the scalar a.
!> On exit, the scalar r.
!> \endverbatim
!>
!> \param[in] B
!> \verbatim
!> B is COMPLEX
!> The scalar b.
!> \endverbatim
!>
!> \param[out] C
!> \verbatim
!> C is REAL
!> The scalar c.
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!> S is COMPLEX
!> The scalar s.
!> \endverbatim
!
! Authors:
! ========
!
!> \author Weslley Pereira, University of Colorado Denver, USA
!
!> \date December 2021
!
!> \ingroup single_blas_level1
!
!> \par Further Details:
! =====================
!>
!> \verbatim
!>
!> Based on the algorithm from
!>
!> Anderson E. (2017)
!> Algorithm 978: Safe Scaling in the Level 1 BLAS
!> ACM Trans Math Softw 44:1--28
!> https://doi.org/10.1145/3061665
!>
!> \endverbatim
!
! =====================================================================
subroutine CROTG( a, b, c, s )
integer, parameter :: wp = kind(1.e0)
!
! -- Reference BLAS level1 routine --
! -- Reference BLAS is a software package provided by Univ. of Tennessee, --
! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!
! .. Constants ..
real(wp), parameter :: zero = 0.0_wp
real(wp), parameter :: one = 1.0_wp
complex(wp), parameter :: czero = 0.0_wp
! ..
! .. Scaling constants ..
real(wp), parameter :: safmin = real(radix(0._wp),wp)**max( &
minexponent(0._wp)-1, &
1-maxexponent(0._wp) &
)
real(wp), parameter :: safmax = real(radix(0._wp),wp)**max( &
1-minexponent(0._wp), &
maxexponent(0._wp)-1 &
)
real(wp), parameter :: rtmin = sqrt( safmin )
! ..
! .. Scalar Arguments ..
real(wp) :: c
complex(wp) :: a, b, s
! ..
! .. Local Scalars ..
real(wp) :: d, f1, f2, g1, g2, h2, u, v, w, rtmax
complex(wp) :: f, fs, g, gs, r, t
! ..
! .. Intrinsic Functions ..
intrinsic :: abs, aimag, conjg, max, min, real, sqrt
! ..
! .. Statement Functions ..
real(wp) :: ABSSQ
! ..
! .. Statement Function definitions ..
ABSSQ( t ) = real( t )**2 + aimag( t )**2
! ..
! .. Executable Statements ..
!
f = a
g = b
if( g == czero ) then
c = one
s = czero
r = f
else if( f == czero ) then
c = zero
if( real(g) == zero ) then
r = abs(aimag(g))
s = conjg( g ) / r
elseif( aimag(g) == zero ) then
r = abs(real(g))
s = conjg( g ) / r
else
g1 = max( abs(real(g)), abs(aimag(g)) )
rtmax = sqrt( safmax/2 )
if( g1 > rtmin .and. g1 < rtmax ) then
!
! Use unscaled algorithm
!
! The following two lines can be replaced by `d = abs( g )`.
! This algorithm do not use the intrinsic complex abs.
g2 = ABSSQ( g )
d = sqrt( g2 )
s = conjg( g ) / d
r = d
else
!
! Use scaled algorithm
!
u = min( safmax, max( safmin, g1 ) )
gs = g / u
! The following two lines can be replaced by `d = abs( gs )`.
! This algorithm do not use the intrinsic complex abs.
g2 = ABSSQ( gs )
d = sqrt( g2 )
s = conjg( gs ) / d
r = d*u
end if
end if
else
f1 = max( abs(real(f)), abs(aimag(f)) )
g1 = max( abs(real(g)), abs(aimag(g)) )
rtmax = sqrt( safmax/4 )
if( f1 > rtmin .and. f1 < rtmax .and. &
g1 > rtmin .and. g1 < rtmax ) then
!
! Use unscaled algorithm
!
f2 = ABSSQ( f )
g2 = ABSSQ( g )
h2 = f2 + g2
! safmin <= f2 <= h2 <= safmax
if( f2 >= h2 * safmin ) then
! safmin <= f2/h2 <= 1, and h2/f2 is finite
c = sqrt( f2 / h2 )
r = f / c
rtmax = rtmax * 2
if( f2 > rtmin .and. h2 < rtmax ) then
! safmin <= sqrt( f2*h2 ) <= safmax
s = conjg( g ) * ( f / sqrt( f2*h2 ) )
else
s = conjg( g ) * ( r / h2 )
end if
else
! f2/h2 <= safmin may be subnormal, and h2/f2 may overflow.
! Moreover,
! safmin <= f2*f2 * safmax < f2 * h2 < h2*h2 * safmin <= safmax,
! sqrt(safmin) <= sqrt(f2 * h2) <= sqrt(safmax).
! Also,
! g2 >> f2, which means that h2 = g2.
d = sqrt( f2 * h2 )
c = f2 / d
if( c >= safmin ) then
r = f / c
else
! f2 / sqrt(f2 * h2) < safmin, then
! sqrt(safmin) <= f2 * sqrt(safmax) <= h2 / sqrt(f2 * h2) <= h2 * (safmin / f2) <= h2 <= safmax
r = f * ( h2 / d )
end if
s = conjg( g ) * ( f / d )
end if
else
!
! Use scaled algorithm
!
u = min( safmax, max( safmin, f1, g1 ) )
gs = g / u
g2 = ABSSQ( gs )
if( f1 / u < rtmin ) then
!
! f is not well-scaled when scaled by g1.
! Use a different scaling for f.
!
v = min( safmax, max( safmin, f1 ) )
w = v / u
fs = f / v
f2 = ABSSQ( fs )
h2 = f2*w**2 + g2
else
!
! Otherwise use the same scaling for f and g.
!
w = one
fs = f / u
f2 = ABSSQ( fs )
h2 = f2 + g2
end if
! safmin <= f2 <= h2 <= safmax
if( f2 >= h2 * safmin ) then
! safmin <= f2/h2 <= 1, and h2/f2 is finite
c = sqrt( f2 / h2 )
r = fs / c
rtmax = rtmax * 2
if( f2 > rtmin .and. h2 < rtmax ) then
! safmin <= sqrt( f2*h2 ) <= safmax
s = conjg( gs ) * ( fs / sqrt( f2*h2 ) )
else
s = conjg( gs ) * ( r / h2 )
end if
else
! f2/h2 <= safmin may be subnormal, and h2/f2 may overflow.
! Moreover,
! safmin <= f2*f2 * safmax < f2 * h2 < h2*h2 * safmin <= safmax,
! sqrt(safmin) <= sqrt(f2 * h2) <= sqrt(safmax).
! Also,
! g2 >> f2, which means that h2 = g2.
d = sqrt( f2 * h2 )
c = f2 / d
if( c >= safmin ) then
r = fs / c
else
! f2 / sqrt(f2 * h2) < safmin, then
! sqrt(safmin) <= f2 * sqrt(safmax) <= h2 / sqrt(f2 * h2) <= h2 * (safmin / f2) <= h2 <= safmax
r = fs * ( h2 / d )
end if
s = conjg( gs ) * ( fs / d )
end if
! Rescale c and r
c = c * w
r = r * u
end if
end if
a = r
return
end subroutine

393
src/csyr2k.c
View file

@ -1,393 +0,0 @@
*> \brief \b CSYR2K
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA,BETA
* INTEGER K,LDA,LDB,LDC,N
* CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CSYR2K performs one of the symmetric rank 2k operations
*>
*> C := alpha*A*B**T + alpha*B*A**T + beta*C,
*>
*> or
*>
*> C := alpha*A**T*B + alpha*B**T*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.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO 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.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' C := alpha*A*B**T + alpha*B*A**T +
*> beta*C.
*>
*> TRANS = 'T' or 't' C := alpha*A**T*B + alpha*B**T*A +
*> beta*C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix C. N must be
*> at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> 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', K specifies the number of rows of the
*> matrices A and B. K must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, ka ), where ka is
*> k when TRANS = 'N' or 'n', and is n otherwise.
*> 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.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA 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 ).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is COMPLEX array, dimension ( LDB, kb ), where kb is
*> k when TRANS = 'N' or 'n', and is n otherwise.
*> 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.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> On entry, LDB 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 ).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is COMPLEX
*> On entry, BETA specifies the scalar beta.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX array, dimension ( LDC, N )
*> 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.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> On entry, LDC specifies the first dimension of C as declared
*> in the calling (sub) program. LDC must be at least
*> max( 1, n ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level3
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 3 Blas routine.
*>
*> -- Written on 8-February-1989.
*> Jack Dongarra, Argonne National Laboratory.
*> Iain Duff, AERE Harwell.
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
*> Sven Hammarling, Numerical Algorithms Group Ltd.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* -- Reference BLAS level3 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA,BETA
INTEGER K,LDA,LDB,LDC,N
CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Local Scalars ..
COMPLEX TEMP1,TEMP2
INTEGER I,INFO,J,L,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
COMPLEX ONE
PARAMETER (ONE= (1.0E+0,0.0E+0))
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
*
* Test the input parameters.
*
IF (LSAME(TRANS,'N')) THEN
NROWA = N
ELSE
NROWA = K
END IF
UPPER = LSAME(UPLO,'U')
*
INFO = 0
IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
INFO = 1
ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
+ (.NOT.LSAME(TRANS,'T'))) THEN
INFO = 2
ELSE IF (N.LT.0) THEN
INFO = 3
ELSE IF (K.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 7
ELSE IF (LDB.LT.MAX(1,NROWA)) THEN
INFO = 9
ELSE IF (LDC.LT.MAX(1,N)) THEN
INFO = 12
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CSYR2K',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
+ (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
*
* And when alpha.eq.zero.
*
IF (ALPHA.EQ.ZERO) THEN
IF (UPPER) THEN
IF (BETA.EQ.ZERO) THEN
DO 20 J = 1,N
DO 10 I = 1,J
C(I,J) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1,N
DO 30 I = 1,J
C(I,J) = BETA*C(I,J)
30 CONTINUE
40 CONTINUE
END IF
ELSE
IF (BETA.EQ.ZERO) THEN
DO 60 J = 1,N
DO 50 I = J,N
C(I,J) = ZERO
50 CONTINUE
60 CONTINUE
ELSE
DO 80 J = 1,N
DO 70 I = J,N
C(I,J) = BETA*C(I,J)
70 CONTINUE
80 CONTINUE
END IF
END IF
RETURN
END IF
*
* Start the operations.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form C := alpha*A*B**T + alpha*B*A**T + C.
*
IF (UPPER) THEN
DO 130 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 90 I = 1,J
C(I,J) = ZERO
90 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 100 I = 1,J
C(I,J) = BETA*C(I,J)
100 CONTINUE
END IF
DO 120 L = 1,K
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
TEMP1 = ALPHA*B(J,L)
TEMP2 = ALPHA*A(J,L)
DO 110 I = 1,J
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
+ B(I,L)*TEMP2
110 CONTINUE
END IF
120 CONTINUE
130 CONTINUE
ELSE
DO 180 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 140 I = J,N
C(I,J) = ZERO
140 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 150 I = J,N
C(I,J) = BETA*C(I,J)
150 CONTINUE
END IF
DO 170 L = 1,K
IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
TEMP1 = ALPHA*B(J,L)
TEMP2 = ALPHA*A(J,L)
DO 160 I = J,N
C(I,J) = C(I,J) + A(I,L)*TEMP1 +
+ B(I,L)*TEMP2
160 CONTINUE
END IF
170 CONTINUE
180 CONTINUE
END IF
ELSE
*
* Form C := alpha*A**T*B + alpha*B**T*A + C.
*
IF (UPPER) THEN
DO 210 J = 1,N
DO 200 I = 1,J
TEMP1 = ZERO
TEMP2 = ZERO
DO 190 L = 1,K
TEMP1 = TEMP1 + A(L,I)*B(L,J)
TEMP2 = TEMP2 + B(L,I)*A(L,J)
190 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+ ALPHA*TEMP2
END IF
200 CONTINUE
210 CONTINUE
ELSE
DO 240 J = 1,N
DO 230 I = J,N
TEMP1 = ZERO
TEMP2 = ZERO
DO 220 L = 1,K
TEMP1 = TEMP1 + A(L,I)*B(L,J)
TEMP2 = TEMP2 + B(L,I)*A(L,J)
220 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+ ALPHA*TEMP2
END IF
230 CONTINUE
240 CONTINUE
END IF
END IF
*
RETURN
*
* End of CSYR2K
*
END

360
src/csyrk.c
View file

@ -1,360 +0,0 @@
*> \brief \b CSYRK
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA,BETA
* INTEGER K,LDA,LDC,N
* CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CSYRK performs one of the symmetric rank k operations
*>
*> C := alpha*A*A**T + beta*C,
*>
*> or
*>
*> C := alpha*A**T*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.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO 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.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' C := alpha*A*A**T + beta*C.
*>
*> TRANS = 'T' or 't' C := alpha*A**T*A + beta*C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix C. N must be
*> at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> 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.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, ka ), where ka is
*> k when TRANS = 'N' or 'n', and is n otherwise.
*> 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.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA 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 ).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is COMPLEX
*> On entry, BETA specifies the scalar beta.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX array, dimension ( LDC, N )
*> 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.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> On entry, LDC specifies the first dimension of C as declared
*> in the calling (sub) program. LDC must be at least
*> max( 1, n ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level3
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 3 Blas routine.
*>
*> -- Written on 8-February-1989.
*> Jack Dongarra, Argonne National Laboratory.
*> Iain Duff, AERE Harwell.
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
*> Sven Hammarling, Numerical Algorithms Group Ltd.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
*
* -- Reference BLAS level3 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA,BETA
INTEGER K,LDA,LDC,N
CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),C(LDC,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Local Scalars ..
COMPLEX TEMP
INTEGER I,INFO,J,L,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
COMPLEX ONE
PARAMETER (ONE= (1.0E+0,0.0E+0))
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
*
* Test the input parameters.
*
IF (LSAME(TRANS,'N')) THEN
NROWA = N
ELSE
NROWA = K
END IF
UPPER = LSAME(UPLO,'U')
*
INFO = 0
IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
INFO = 1
ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
+ (.NOT.LSAME(TRANS,'T'))) THEN
INFO = 2
ELSE IF (N.LT.0) THEN
INFO = 3
ELSE IF (K.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 7
ELSE IF (LDC.LT.MAX(1,N)) THEN
INFO = 10
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CSYRK ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
+ (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
*
* And when alpha.eq.zero.
*
IF (ALPHA.EQ.ZERO) THEN
IF (UPPER) THEN
IF (BETA.EQ.ZERO) THEN
DO 20 J = 1,N
DO 10 I = 1,J
C(I,J) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1,N
DO 30 I = 1,J
C(I,J) = BETA*C(I,J)
30 CONTINUE
40 CONTINUE
END IF
ELSE
IF (BETA.EQ.ZERO) THEN
DO 60 J = 1,N
DO 50 I = J,N
C(I,J) = ZERO
50 CONTINUE
60 CONTINUE
ELSE
DO 80 J = 1,N
DO 70 I = J,N
C(I,J) = BETA*C(I,J)
70 CONTINUE
80 CONTINUE
END IF
END IF
RETURN
END IF
*
* Start the operations.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form C := alpha*A*A**T + beta*C.
*
IF (UPPER) THEN
DO 130 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 90 I = 1,J
C(I,J) = ZERO
90 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 100 I = 1,J
C(I,J) = BETA*C(I,J)
100 CONTINUE
END IF
DO 120 L = 1,K
IF (A(J,L).NE.ZERO) THEN
TEMP = ALPHA*A(J,L)
DO 110 I = 1,J
C(I,J) = C(I,J) + TEMP*A(I,L)
110 CONTINUE
END IF
120 CONTINUE
130 CONTINUE
ELSE
DO 180 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 140 I = J,N
C(I,J) = ZERO
140 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 150 I = J,N
C(I,J) = BETA*C(I,J)
150 CONTINUE
END IF
DO 170 L = 1,K
IF (A(J,L).NE.ZERO) THEN
TEMP = ALPHA*A(J,L)
DO 160 I = J,N
C(I,J) = C(I,J) + TEMP*A(I,L)
160 CONTINUE
END IF
170 CONTINUE
180 CONTINUE
END IF
ELSE
*
* Form C := alpha*A**T*A + beta*C.
*
IF (UPPER) THEN
DO 210 J = 1,N
DO 200 I = 1,J
TEMP = ZERO
DO 190 L = 1,K
TEMP = TEMP + A(L,I)*A(L,J)
190 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
200 CONTINUE
210 CONTINUE
ELSE
DO 240 J = 1,N
DO 230 I = J,N
TEMP = ZERO
DO 220 L = 1,K
TEMP = TEMP + A(L,I)*A(L,J)
220 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
230 CONTINUE
240 CONTINUE
END IF
END IF
*
RETURN
*
* End of CSYRK
*
END

426
src/ctbmv.c
View file

@ -1,426 +0,0 @@
*> \brief \b CTBMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,K,LDA,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CTBMV performs one of the matrix-vector operations
*>
*> x := A*x, or x := A**T*x, or x := A**H*x,
*>
*> where x is an n element vector and A is an n by n unit, or non-unit,
*> upper or lower triangular band matrix, with ( k + 1 ) diagonals.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO 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.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' x := A*x.
*>
*> TRANS = 'T' or 't' x := A**T*x.
*>
*> TRANS = 'C' or 'c' x := A**H*x.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> On entry, DIAG 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.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> On entry with UPLO = 'U' or 'u', K specifies the number of
*> super-diagonals of the matrix A.
*> On entry with UPLO = 'L' or 'l', K specifies the number of
*> sub-diagonals of the matrix A.
*> K must satisfy 0 .le. K.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, N ).
*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
*> by n part of the array A must contain the upper triangular
*> band part of the matrix of coefficients, supplied column by
*> column, with the leading diagonal of the matrix in row
*> ( k + 1 ) of the array, the first super-diagonal starting at
*> position 2 in row k, and so on. The top left k by k triangle
*> of the array A is not referenced.
*> The following program segment will transfer an upper
*> triangular band matrix from conventional full matrix storage
*> to band storage:
*>
*> DO 20, J = 1, N
*> M = K + 1 - J
*> DO 10, I = MAX( 1, J - K ), J
*> A( M + I, J ) = matrix( I, J )
*> 10 CONTINUE
*> 20 CONTINUE
*>
*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
*> by n part of the array A must contain the lower triangular
*> band part of the matrix of coefficients, supplied column by
*> column, with the leading diagonal of the matrix in row 1 of
*> the array, the first sub-diagonal starting at position 1 in
*> row 2, and so on. The bottom right k by k triangle of the
*> array A is not referenced.
*> The following program segment will transfer a lower
*> triangular band matrix from conventional full matrix storage
*> to band storage:
*>
*> DO 20, J = 1, N
*> M = 1 - J
*> DO 10, I = J, MIN( N, J + K )
*> A( M + I, J ) = matrix( I, J )
*> 10 CONTINUE
*> 20 CONTINUE
*>
*> Note that when DIAG = 'U' or 'u' the elements of the array A
*> corresponding to the diagonal elements of the matrix are not
*> referenced, but are assumed to be unity.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> ( k + 1 ).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX array, 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
*> transformed vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INCX,K,LDA,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),X(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
* .. Local Scalars ..
COMPLEX TEMP
INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L
LOGICAL NOCONJ,NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,MAX,MIN
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ .NOT.LSAME(TRANS,'C')) THEN
INFO = 2
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (K.LT.0) THEN
INFO = 5
ELSE IF (LDA.LT. (K+1)) THEN
INFO = 7
ELSE IF (INCX.EQ.0) THEN
INFO = 9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CTBMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF (N.EQ.0) RETURN
*
NOCONJ = LSAME(TRANS,'T')
NOUNIT = LSAME(DIAG,'N')
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through A.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := A*x.
*
IF (LSAME(UPLO,'U')) THEN
KPLUS1 = K + 1
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = X(J)
L = KPLUS1 - J
DO 10 I = MAX(1,J-K),J - 1
X(I) = X(I) + TEMP*A(L+I,J)
10 CONTINUE
IF (NOUNIT) X(J) = X(J)*A(KPLUS1,J)
END IF
20 CONTINUE
ELSE
JX = KX
DO 40 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = X(JX)
IX = KX
L = KPLUS1 - J
DO 30 I = MAX(1,J-K),J - 1
X(IX) = X(IX) + TEMP*A(L+I,J)
IX = IX + INCX
30 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*A(KPLUS1,J)
END IF
JX = JX + INCX
IF (J.GT.K) KX = KX + INCX
40 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 60 J = N,1,-1
IF (X(J).NE.ZERO) THEN
TEMP = X(J)
L = 1 - J
DO 50 I = MIN(N,J+K),J + 1,-1
X(I) = X(I) + TEMP*A(L+I,J)
50 CONTINUE
IF (NOUNIT) X(J) = X(J)*A(1,J)
END IF
60 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 80 J = N,1,-1
IF (X(JX).NE.ZERO) THEN
TEMP = X(JX)
IX = KX
L = 1 - J
DO 70 I = MIN(N,J+K),J + 1,-1
X(IX) = X(IX) + TEMP*A(L+I,J)
IX = IX - INCX
70 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*A(1,J)
END IF
JX = JX - INCX
IF ((N-J).GE.K) KX = KX - INCX
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := A**T*x or x := A**H*x.
*
IF (LSAME(UPLO,'U')) THEN
KPLUS1 = K + 1
IF (INCX.EQ.1) THEN
DO 110 J = N,1,-1
TEMP = X(J)
L = KPLUS1 - J
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J)
DO 90 I = J - 1,MAX(1,J-K),-1
TEMP = TEMP + A(L+I,J)*X(I)
90 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*CONJG(A(KPLUS1,J))
DO 100 I = J - 1,MAX(1,J-K),-1
TEMP = TEMP + CONJG(A(L+I,J))*X(I)
100 CONTINUE
END IF
X(J) = TEMP
110 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 140 J = N,1,-1
TEMP = X(JX)
KX = KX - INCX
IX = KX
L = KPLUS1 - J
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J)
DO 120 I = J - 1,MAX(1,J-K),-1
TEMP = TEMP + A(L+I,J)*X(IX)
IX = IX - INCX
120 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*CONJG(A(KPLUS1,J))
DO 130 I = J - 1,MAX(1,J-K),-1
TEMP = TEMP + CONJG(A(L+I,J))*X(IX)
IX = IX - INCX
130 CONTINUE
END IF
X(JX) = TEMP
JX = JX - INCX
140 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 170 J = 1,N
TEMP = X(J)
L = 1 - J
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*A(1,J)
DO 150 I = J + 1,MIN(N,J+K)
TEMP = TEMP + A(L+I,J)*X(I)
150 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*CONJG(A(1,J))
DO 160 I = J + 1,MIN(N,J+K)
TEMP = TEMP + CONJG(A(L+I,J))*X(I)
160 CONTINUE
END IF
X(J) = TEMP
170 CONTINUE
ELSE
JX = KX
DO 200 J = 1,N
TEMP = X(JX)
KX = KX + INCX
IX = KX
L = 1 - J
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*A(1,J)
DO 180 I = J + 1,MIN(N,J+K)
TEMP = TEMP + A(L+I,J)*X(IX)
IX = IX + INCX
180 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*CONJG(A(1,J))
DO 190 I = J + 1,MIN(N,J+K)
TEMP = TEMP + CONJG(A(L+I,J))*X(IX)
IX = IX + INCX
190 CONTINUE
END IF
X(JX) = TEMP
JX = JX + INCX
200 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of CTBMV
*
END

429
src/ctbsv.c
View file

@ -1,429 +0,0 @@
*> \brief \b CTBSV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,K,LDA,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CTBSV solves one of the systems of equations
*>
*> A*x = b, or A**T*x = b, or A**H*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 band matrix, with ( k + 1 )
*> diagonals.
*>
*> No test for singularity or near-singularity is included in this
*> routine. Such tests must be performed before calling this routine.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO 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.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the equations to be solved as
*> follows:
*>
*> TRANS = 'N' or 'n' A*x = b.
*>
*> TRANS = 'T' or 't' A**T*x = b.
*>
*> TRANS = 'C' or 'c' A**H*x = b.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> On entry, DIAG 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.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> On entry with UPLO = 'U' or 'u', K specifies the number of
*> super-diagonals of the matrix A.
*> On entry with UPLO = 'L' or 'l', K specifies the number of
*> sub-diagonals of the matrix A.
*> K must satisfy 0 .le. K.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, N )
*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
*> by n part of the array A must contain the upper triangular
*> band part of the matrix of coefficients, supplied column by
*> column, with the leading diagonal of the matrix in row
*> ( k + 1 ) of the array, the first super-diagonal starting at
*> position 2 in row k, and so on. The top left k by k triangle
*> of the array A is not referenced.
*> The following program segment will transfer an upper
*> triangular band matrix from conventional full matrix storage
*> to band storage:
*>
*> DO 20, J = 1, N
*> M = K + 1 - J
*> DO 10, I = MAX( 1, J - K ), J
*> A( M + I, J ) = matrix( I, J )
*> 10 CONTINUE
*> 20 CONTINUE
*>
*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
*> by n part of the array A must contain the lower triangular
*> band part of the matrix of coefficients, supplied column by
*> column, with the leading diagonal of the matrix in row 1 of
*> the array, the first sub-diagonal starting at position 1 in
*> row 2, and so on. The bottom right k by k triangle of the
*> array A is not referenced.
*> The following program segment will transfer a lower
*> triangular band matrix from conventional full matrix storage
*> to band storage:
*>
*> DO 20, J = 1, N
*> M = 1 - J
*> DO 10, I = J, MIN( N, J + K )
*> A( M + I, J ) = matrix( I, J )
*> 10 CONTINUE
*> 20 CONTINUE
*>
*> Note that when DIAG = 'U' or 'u' the elements of the array A
*> corresponding to the diagonal elements of the matrix are not
*> referenced, but are assumed to be unity.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> ( k + 1 ).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX array, 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.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INCX,K,LDA,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),X(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
* .. Local Scalars ..
COMPLEX TEMP
INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L
LOGICAL NOCONJ,NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,MAX,MIN
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ .NOT.LSAME(TRANS,'C')) THEN
INFO = 2
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (K.LT.0) THEN
INFO = 5
ELSE IF (LDA.LT. (K+1)) THEN
INFO = 7
ELSE IF (INCX.EQ.0) THEN
INFO = 9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CTBSV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF (N.EQ.0) RETURN
*
NOCONJ = LSAME(TRANS,'T')
NOUNIT = LSAME(DIAG,'N')
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of A are
* accessed by sequentially with one pass through A.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := inv( A )*x.
*
IF (LSAME(UPLO,'U')) THEN
KPLUS1 = K + 1
IF (INCX.EQ.1) THEN
DO 20 J = N,1,-1
IF (X(J).NE.ZERO) THEN
L = KPLUS1 - J
IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J)
TEMP = X(J)
DO 10 I = J - 1,MAX(1,J-K),-1
X(I) = X(I) - TEMP*A(L+I,J)
10 CONTINUE
END IF
20 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 40 J = N,1,-1
KX = KX - INCX
IF (X(JX).NE.ZERO) THEN
IX = KX
L = KPLUS1 - J
IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J)
TEMP = X(JX)
DO 30 I = J - 1,MAX(1,J-K),-1
X(IX) = X(IX) - TEMP*A(L+I,J)
IX = IX - INCX
30 CONTINUE
END IF
JX = JX - INCX
40 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
L = 1 - J
IF (NOUNIT) X(J) = X(J)/A(1,J)
TEMP = X(J)
DO 50 I = J + 1,MIN(N,J+K)
X(I) = X(I) - TEMP*A(L+I,J)
50 CONTINUE
END IF
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
KX = KX + INCX
IF (X(JX).NE.ZERO) THEN
IX = KX
L = 1 - J
IF (NOUNIT) X(JX) = X(JX)/A(1,J)
TEMP = X(JX)
DO 70 I = J + 1,MIN(N,J+K)
X(IX) = X(IX) - TEMP*A(L+I,J)
IX = IX + INCX
70 CONTINUE
END IF
JX = JX + INCX
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := inv( A**T )*x or x := inv( A**H )*x.
*
IF (LSAME(UPLO,'U')) THEN
KPLUS1 = K + 1
IF (INCX.EQ.1) THEN
DO 110 J = 1,N
TEMP = X(J)
L = KPLUS1 - J
IF (NOCONJ) THEN
DO 90 I = MAX(1,J-K),J - 1
TEMP = TEMP - A(L+I,J)*X(I)
90 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J)
ELSE
DO 100 I = MAX(1,J-K),J - 1
TEMP = TEMP - CONJG(A(L+I,J))*X(I)
100 CONTINUE
IF (NOUNIT) TEMP = TEMP/CONJG(A(KPLUS1,J))
END IF
X(J) = TEMP
110 CONTINUE
ELSE
JX = KX
DO 140 J = 1,N
TEMP = X(JX)
IX = KX
L = KPLUS1 - J
IF (NOCONJ) THEN
DO 120 I = MAX(1,J-K),J - 1
TEMP = TEMP - A(L+I,J)*X(IX)
IX = IX + INCX
120 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J)
ELSE
DO 130 I = MAX(1,J-K),J - 1
TEMP = TEMP - CONJG(A(L+I,J))*X(IX)
IX = IX + INCX
130 CONTINUE
IF (NOUNIT) TEMP = TEMP/CONJG(A(KPLUS1,J))
END IF
X(JX) = TEMP
JX = JX + INCX
IF (J.GT.K) KX = KX + INCX
140 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 170 J = N,1,-1
TEMP = X(J)
L = 1 - J
IF (NOCONJ) THEN
DO 150 I = MIN(N,J+K),J + 1,-1
TEMP = TEMP - A(L+I,J)*X(I)
150 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(1,J)
ELSE
DO 160 I = MIN(N,J+K),J + 1,-1
TEMP = TEMP - CONJG(A(L+I,J))*X(I)
160 CONTINUE
IF (NOUNIT) TEMP = TEMP/CONJG(A(1,J))
END IF
X(J) = TEMP
170 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 200 J = N,1,-1
TEMP = X(JX)
IX = KX
L = 1 - J
IF (NOCONJ) THEN
DO 180 I = MIN(N,J+K),J + 1,-1
TEMP = TEMP - A(L+I,J)*X(IX)
IX = IX - INCX
180 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(1,J)
ELSE
DO 190 I = MIN(N,J+K),J + 1,-1
TEMP = TEMP - CONJG(A(L+I,J))*X(IX)
IX = IX - INCX
190 CONTINUE
IF (NOUNIT) TEMP = TEMP/CONJG(A(1,J))
END IF
X(JX) = TEMP
JX = JX - INCX
IF ((N-J).GE.K) KX = KX - INCX
200 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of CTBSV
*
END

385
src/ctpmv.c
View file

@ -1,385 +0,0 @@
*> \brief \b CTPMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX AP(*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CTPMV performs one of the matrix-vector operations
*>
*> x := A*x, or x := A**T*x, or x := A**H*x,
*>
*> where x is an n element vector and A is an n by n unit, or non-unit,
*> upper or lower triangular matrix, supplied in packed form.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO 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.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' x := A*x.
*>
*> TRANS = 'T' or 't' x := A**T*x.
*>
*> TRANS = 'C' or 'c' x := A**H*x.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> On entry, DIAG 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.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is COMPLEX array, dimension at least
*> ( ( n*( n + 1 ) )/2 ).
*> Before entry with UPLO = 'U' or 'u', the array AP must
*> contain the upper triangular matrix packed sequentially,
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
*> respectively, and so on.
*> Before entry with UPLO = 'L' or 'l', the array AP must
*> contain the lower triangular matrix packed sequentially,
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
*> respectively, and so on.
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
*> A are not referenced, but are assumed to be unity.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX array, 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
*> transformed vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INCX,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
COMPLEX AP(*),X(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
* .. Local Scalars ..
COMPLEX TEMP
INTEGER I,INFO,IX,J,JX,K,KK,KX
LOGICAL NOCONJ,NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ .NOT.LSAME(TRANS,'C')) THEN
INFO = 2
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (INCX.EQ.0) THEN
INFO = 7
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CTPMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF (N.EQ.0) RETURN
*
NOCONJ = LSAME(TRANS,'T')
NOUNIT = LSAME(DIAG,'N')
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of AP are
* accessed sequentially with one pass through AP.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x:= A*x.
*
IF (LSAME(UPLO,'U')) THEN
KK = 1
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (X(J).NE.ZERO) THEN
TEMP = X(J)
K = KK
DO 10 I = 1,J - 1
X(I) = X(I) + TEMP*AP(K)
K = K + 1
10 CONTINUE
IF (NOUNIT) X(J) = X(J)*AP(KK+J-1)
END IF
KK = KK + J
20 CONTINUE
ELSE
JX = KX
DO 40 J = 1,N
IF (X(JX).NE.ZERO) THEN
TEMP = X(JX)
IX = KX
DO 30 K = KK,KK + J - 2
X(IX) = X(IX) + TEMP*AP(K)
IX = IX + INCX
30 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*AP(KK+J-1)
END IF
JX = JX + INCX
KK = KK + J
40 CONTINUE
END IF
ELSE
KK = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 60 J = N,1,-1
IF (X(J).NE.ZERO) THEN
TEMP = X(J)
K = KK
DO 50 I = N,J + 1,-1
X(I) = X(I) + TEMP*AP(K)
K = K - 1
50 CONTINUE
IF (NOUNIT) X(J) = X(J)*AP(KK-N+J)
END IF
KK = KK - (N-J+1)
60 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 80 J = N,1,-1
IF (X(JX).NE.ZERO) THEN
TEMP = X(JX)
IX = KX
DO 70 K = KK,KK - (N- (J+1)),-1
X(IX) = X(IX) + TEMP*AP(K)
IX = IX - INCX
70 CONTINUE
IF (NOUNIT) X(JX) = X(JX)*AP(KK-N+J)
END IF
JX = JX - INCX
KK = KK - (N-J+1)
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := A**T*x or x := A**H*x.
*
IF (LSAME(UPLO,'U')) THEN
KK = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 110 J = N,1,-1
TEMP = X(J)
K = KK - 1
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*AP(KK)
DO 90 I = J - 1,1,-1
TEMP = TEMP + AP(K)*X(I)
K = K - 1
90 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*CONJG(AP(KK))
DO 100 I = J - 1,1,-1
TEMP = TEMP + CONJG(AP(K))*X(I)
K = K - 1
100 CONTINUE
END IF
X(J) = TEMP
KK = KK - J
110 CONTINUE
ELSE
JX = KX + (N-1)*INCX
DO 140 J = N,1,-1
TEMP = X(JX)
IX = JX
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*AP(KK)
DO 120 K = KK - 1,KK - J + 1,-1
IX = IX - INCX
TEMP = TEMP + AP(K)*X(IX)
120 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*CONJG(AP(KK))
DO 130 K = KK - 1,KK - J + 1,-1
IX = IX - INCX
TEMP = TEMP + CONJG(AP(K))*X(IX)
130 CONTINUE
END IF
X(JX) = TEMP
JX = JX - INCX
KK = KK - J
140 CONTINUE
END IF
ELSE
KK = 1
IF (INCX.EQ.1) THEN
DO 170 J = 1,N
TEMP = X(J)
K = KK + 1
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*AP(KK)
DO 150 I = J + 1,N
TEMP = TEMP + AP(K)*X(I)
K = K + 1
150 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*CONJG(AP(KK))
DO 160 I = J + 1,N
TEMP = TEMP + CONJG(AP(K))*X(I)
K = K + 1
160 CONTINUE
END IF
X(J) = TEMP
KK = KK + (N-J+1)
170 CONTINUE
ELSE
JX = KX
DO 200 J = 1,N
TEMP = X(JX)
IX = JX
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*AP(KK)
DO 180 K = KK + 1,KK + N - J
IX = IX + INCX
TEMP = TEMP + AP(K)*X(IX)
180 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*CONJG(AP(KK))
DO 190 K = KK + 1,KK + N - J
IX = IX + INCX
TEMP = TEMP + CONJG(AP(K))*X(IX)
190 CONTINUE
END IF
X(JX) = TEMP
JX = JX + INCX
KK = KK + (N-J+1)
200 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of CTPMV
*
END

387
src/ctpsv.c
View file

@ -1,387 +0,0 @@
*> \brief \b CTPSV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX AP(*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CTPSV solves one of the systems of equations
*>
*> A*x = b, or A**T*x = b, or A**H*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, supplied in packed form.
*>
*> No test for singularity or near-singularity is included in this
*> routine. Such tests must be performed before calling this routine.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO 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.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the equations to be solved as
*> follows:
*>
*> TRANS = 'N' or 'n' A*x = b.
*>
*> TRANS = 'T' or 't' A**T*x = b.
*>
*> TRANS = 'C' or 'c' A**H*x = b.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> On entry, DIAG 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.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is COMPLEX array, dimension at least
*> ( ( n*( n + 1 ) )/2 ).
*> Before entry with UPLO = 'U' or 'u', the array AP must
*> contain the upper triangular matrix packed sequentially,
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
*> respectively, and so on.
*> Before entry with UPLO = 'L' or 'l', the array AP must
*> contain the lower triangular matrix packed sequentially,
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
*> respectively, and so on.
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
*> A are not referenced, but are assumed to be unity.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX array, 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.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INCX,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
COMPLEX AP(*),X(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
* .. Local Scalars ..
COMPLEX TEMP
INTEGER I,INFO,IX,J,JX,K,KK,KX
LOGICAL NOCONJ,NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ .NOT.LSAME(TRANS,'C')) THEN
INFO = 2
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (INCX.EQ.0) THEN
INFO = 7
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CTPSV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF (N.EQ.0) RETURN
*
NOCONJ = LSAME(TRANS,'T')
NOUNIT = LSAME(DIAG,'N')
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of AP are
* accessed sequentially with one pass through AP.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := inv( A )*x.
*
IF (LSAME(UPLO,'U')) THEN
KK = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 20 J = N,1,-1
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/AP(KK)
TEMP = X(J)
K = KK - 1
DO 10 I = J - 1,1,-1
X(I) = X(I) - TEMP*AP(K)
K = K - 1
10 CONTINUE
END IF
KK = KK - J
20 CONTINUE
ELSE
JX = KX + (N-1)*INCX
DO 40 J = N,1,-1
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/AP(KK)
TEMP = X(JX)
IX = JX
DO 30 K = KK - 1,KK - J + 1,-1
IX = IX - INCX
X(IX) = X(IX) - TEMP*AP(K)
30 CONTINUE
END IF
JX = JX - INCX
KK = KK - J
40 CONTINUE
END IF
ELSE
KK = 1
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/AP(KK)
TEMP = X(J)
K = KK + 1
DO 50 I = J + 1,N
X(I) = X(I) - TEMP*AP(K)
K = K + 1
50 CONTINUE
END IF
KK = KK + (N-J+1)
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/AP(KK)
TEMP = X(JX)
IX = JX
DO 70 K = KK + 1,KK + N - J
IX = IX + INCX
X(IX) = X(IX) - TEMP*AP(K)
70 CONTINUE
END IF
JX = JX + INCX
KK = KK + (N-J+1)
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := inv( A**T )*x or x := inv( A**H )*x.
*
IF (LSAME(UPLO,'U')) THEN
KK = 1
IF (INCX.EQ.1) THEN
DO 110 J = 1,N
TEMP = X(J)
K = KK
IF (NOCONJ) THEN
DO 90 I = 1,J - 1
TEMP = TEMP - AP(K)*X(I)
K = K + 1
90 CONTINUE
IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)
ELSE
DO 100 I = 1,J - 1
TEMP = TEMP - CONJG(AP(K))*X(I)
K = K + 1
100 CONTINUE
IF (NOUNIT) TEMP = TEMP/CONJG(AP(KK+J-1))
END IF
X(J) = TEMP
KK = KK + J
110 CONTINUE
ELSE
JX = KX
DO 140 J = 1,N
TEMP = X(JX)
IX = KX
IF (NOCONJ) THEN
DO 120 K = KK,KK + J - 2
TEMP = TEMP - AP(K)*X(IX)
IX = IX + INCX
120 CONTINUE
IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)
ELSE
DO 130 K = KK,KK + J - 2
TEMP = TEMP - CONJG(AP(K))*X(IX)
IX = IX + INCX
130 CONTINUE
IF (NOUNIT) TEMP = TEMP/CONJG(AP(KK+J-1))
END IF
X(JX) = TEMP
JX = JX + INCX
KK = KK + J
140 CONTINUE
END IF
ELSE
KK = (N* (N+1))/2
IF (INCX.EQ.1) THEN
DO 170 J = N,1,-1
TEMP = X(J)
K = KK
IF (NOCONJ) THEN
DO 150 I = N,J + 1,-1
TEMP = TEMP - AP(K)*X(I)
K = K - 1
150 CONTINUE
IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)
ELSE
DO 160 I = N,J + 1,-1
TEMP = TEMP - CONJG(AP(K))*X(I)
K = K - 1
160 CONTINUE
IF (NOUNIT) TEMP = TEMP/CONJG(AP(KK-N+J))
END IF
X(J) = TEMP
KK = KK - (N-J+1)
170 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 200 J = N,1,-1
TEMP = X(JX)
IX = KX
IF (NOCONJ) THEN
DO 180 K = KK,KK - (N- (J+1)),-1
TEMP = TEMP - AP(K)*X(IX)
IX = IX - INCX
180 CONTINUE
IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)
ELSE
DO 190 K = KK,KK - (N- (J+1)),-1
TEMP = TEMP - CONJG(AP(K))*X(IX)
IX = IX - INCX
190 CONTINUE
IF (NOUNIT) TEMP = TEMP/CONJG(AP(KK-N+J))
END IF
X(JX) = TEMP
JX = JX - INCX
KK = KK - (N-J+1)
200 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of CTPSV
*
END

449
src/ctrmm.c
View file

@ -1,449 +0,0 @@
*> \brief \b CTRMM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA
* INTEGER LDA,LDB,M,N
* CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),B(LDB,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CTRMM performs one of the matrix-matrix operations
*>
*> B := alpha*op( A )*B, or B := alpha*B*op( A )
*>
*> where alpha is a scalar, B is an m by n matrix, A is a unit, or
*> non-unit, upper or lower triangular matrix and op( A ) is one of
*>
*> op( A ) = A or op( A ) = A**T or op( A ) = A**H.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> On entry, SIDE specifies whether op( A ) multiplies B from
*> the left or right as follows:
*>
*> SIDE = 'L' or 'l' B := alpha*op( A )*B.
*>
*> SIDE = 'R' or 'r' B := alpha*B*op( A ).
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the matrix A 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.
*> \endverbatim
*>
*> \param[in] TRANSA
*> \verbatim
*> TRANSA is CHARACTER*1
*> On entry, TRANSA 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**T.
*>
*> TRANSA = 'C' or 'c' op( A ) = A**H.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> On entry, DIAG 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.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of B. M must be at
*> least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of B. N must be
*> at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha. When alpha is
*> zero then A is not referenced and B need not be set before
*> entry.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, k ), where k is m
*> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
*> Before entry with UPLO = 'U' or 'u', the leading k by k
*> 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 k by k
*> 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.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA 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 ), when SIDE = 'R' or 'r'
*> then LDA must be at least max( 1, n ).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX array, dimension ( LDB, N ).
*> Before entry, the leading m by n part of the array B must
*> contain the matrix B, and on exit is overwritten by the
*> transformed matrix.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> On entry, LDB specifies the first dimension of B as declared
*> in the calling (sub) program. LDB must be at least
*> max( 1, m ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level3
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 3 Blas routine.
*>
*> -- Written on 8-February-1989.
*> Jack Dongarra, Argonne National Laboratory.
*> Iain Duff, AERE Harwell.
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
*> Sven Hammarling, Numerical Algorithms Group Ltd.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*
* -- Reference BLAS level3 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA
INTEGER LDA,LDB,M,N
CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),B(LDB,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,MAX
* ..
* .. Local Scalars ..
COMPLEX TEMP
INTEGER I,INFO,J,K,NROWA
LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER
* ..
* .. Parameters ..
COMPLEX ONE
PARAMETER (ONE= (1.0E+0,0.0E+0))
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
*
* Test the input parameters.
*
LSIDE = LSAME(SIDE,'L')
IF (LSIDE) THEN
NROWA = M
ELSE
NROWA = N
END IF
NOCONJ = LSAME(TRANSA,'T')
NOUNIT = LSAME(DIAG,'N')
UPPER = LSAME(UPLO,'U')
*
INFO = 0
IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
INFO = 1
ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
INFO = 2
ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
+ (.NOT.LSAME(TRANSA,'T')) .AND.
+ (.NOT.LSAME(TRANSA,'C'))) THEN
INFO = 3
ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
INFO = 4
ELSE IF (M.LT.0) THEN
INFO = 5
ELSE IF (N.LT.0) THEN
INFO = 6
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 9
ELSE IF (LDB.LT.MAX(1,M)) THEN
INFO = 11
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CTRMM ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF (M.EQ.0 .OR. N.EQ.0) RETURN
*
* And when alpha.eq.zero.
*
IF (ALPHA.EQ.ZERO) THEN
DO 20 J = 1,N
DO 10 I = 1,M
B(I,J) = ZERO
10 CONTINUE
20 CONTINUE
RETURN
END IF
*
* Start the operations.
*
IF (LSIDE) THEN
IF (LSAME(TRANSA,'N')) THEN
*
* Form B := alpha*A*B.
*
IF (UPPER) THEN
DO 50 J = 1,N
DO 40 K = 1,M
IF (B(K,J).NE.ZERO) THEN
TEMP = ALPHA*B(K,J)
DO 30 I = 1,K - 1
B(I,J) = B(I,J) + TEMP*A(I,K)
30 CONTINUE
IF (NOUNIT) TEMP = TEMP*A(K,K)
B(K,J) = TEMP
END IF
40 CONTINUE
50 CONTINUE
ELSE
DO 80 J = 1,N
DO 70 K = M,1,-1
IF (B(K,J).NE.ZERO) THEN
TEMP = ALPHA*B(K,J)
B(K,J) = TEMP
IF (NOUNIT) B(K,J) = B(K,J)*A(K,K)
DO 60 I = K + 1,M
B(I,J) = B(I,J) + TEMP*A(I,K)
60 CONTINUE
END IF
70 CONTINUE
80 CONTINUE
END IF
ELSE
*
* Form B := alpha*A**T*B or B := alpha*A**H*B.
*
IF (UPPER) THEN
DO 120 J = 1,N
DO 110 I = M,1,-1
TEMP = B(I,J)
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*A(I,I)
DO 90 K = 1,I - 1
TEMP = TEMP + A(K,I)*B(K,J)
90 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*CONJG(A(I,I))
DO 100 K = 1,I - 1
TEMP = TEMP + CONJG(A(K,I))*B(K,J)
100 CONTINUE
END IF
B(I,J) = ALPHA*TEMP
110 CONTINUE
120 CONTINUE
ELSE
DO 160 J = 1,N
DO 150 I = 1,M
TEMP = B(I,J)
IF (NOCONJ) THEN
IF (NOUNIT) TEMP = TEMP*A(I,I)
DO 130 K = I + 1,M
TEMP = TEMP + A(K,I)*B(K,J)
130 CONTINUE
ELSE
IF (NOUNIT) TEMP = TEMP*CONJG(A(I,I))
DO 140 K = I + 1,M
TEMP = TEMP + CONJG(A(K,I))*B(K,J)
140 CONTINUE
END IF
B(I,J) = ALPHA*TEMP
150 CONTINUE
160 CONTINUE
END IF
END IF
ELSE
IF (LSAME(TRANSA,'N')) THEN
*
* Form B := alpha*B*A.
*
IF (UPPER) THEN
DO 200 J = N,1,-1
TEMP = ALPHA
IF (NOUNIT) TEMP = TEMP*A(J,J)
DO 170 I = 1,M
B(I,J) = TEMP*B(I,J)
170 CONTINUE
DO 190 K = 1,J - 1
IF (A(K,J).NE.ZERO) THEN
TEMP = ALPHA*A(K,J)
DO 180 I = 1,M
B(I,J) = B(I,J) + TEMP*B(I,K)
180 CONTINUE
END IF
190 CONTINUE
200 CONTINUE
ELSE
DO 240 J = 1,N
TEMP = ALPHA
IF (NOUNIT) TEMP = TEMP*A(J,J)
DO 210 I = 1,M
B(I,J) = TEMP*B(I,J)
210 CONTINUE
DO 230 K = J + 1,N
IF (A(K,J).NE.ZERO) THEN
TEMP = ALPHA*A(K,J)
DO 220 I = 1,M
B(I,J) = B(I,J) + TEMP*B(I,K)
220 CONTINUE
END IF
230 CONTINUE
240 CONTINUE
END IF
ELSE
*
* Form B := alpha*B*A**T or B := alpha*B*A**H.
*
IF (UPPER) THEN
DO 280 K = 1,N
DO 260 J = 1,K - 1
IF (A(J,K).NE.ZERO) THEN
IF (NOCONJ) THEN
TEMP = ALPHA*A(J,K)
ELSE
TEMP = ALPHA*CONJG(A(J,K))
END IF
DO 250 I = 1,M
B(I,J) = B(I,J) + TEMP*B(I,K)
250 CONTINUE
END IF
260 CONTINUE
TEMP = ALPHA
IF (NOUNIT) THEN
IF (NOCONJ) THEN
TEMP = TEMP*A(K,K)
ELSE
TEMP = TEMP*CONJG(A(K,K))
END IF
END IF
IF (TEMP.NE.ONE) THEN
DO 270 I = 1,M
B(I,K) = TEMP*B(I,K)
270 CONTINUE
END IF
280 CONTINUE
ELSE
DO 320 K = N,1,-1
DO 300 J = K + 1,N
IF (A(J,K).NE.ZERO) THEN
IF (NOCONJ) THEN
TEMP = ALPHA*A(J,K)
ELSE
TEMP = ALPHA*CONJG(A(J,K))
END IF
DO 290 I = 1,M
B(I,J) = B(I,J) + TEMP*B(I,K)
290 CONTINUE
END IF
300 CONTINUE
TEMP = ALPHA
IF (NOUNIT) THEN
IF (NOCONJ) THEN
TEMP = TEMP*A(K,K)
ELSE
TEMP = TEMP*CONJG(A(K,K))
END IF
END IF
IF (TEMP.NE.ONE) THEN
DO 310 I = 1,M
B(I,K) = TEMP*B(I,K)
310 CONTINUE
END IF
320 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of CTRMM
*
END

474
src/ctrsm.c
View file

@ -1,474 +0,0 @@
*> \brief \b CTRSM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA
* INTEGER LDA,LDB,M,N
* CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),B(LDB,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CTRSM solves one of the matrix equations
*>
*> op( A )*X = alpha*B, or X*op( A ) = alpha*B,
*>
*> where alpha is a scalar, X and B are m by n matrices, A is a unit, or
*> non-unit, upper or lower triangular matrix and op( A ) is one of
*>
*> op( A ) = A or op( A ) = A**T or op( A ) = A**H.
*>
*> The matrix X is overwritten on B.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> On entry, SIDE specifies whether op( A ) appears on the left
*> or right of X as follows:
*>
*> SIDE = 'L' or 'l' op( A )*X = alpha*B.
*>
*> SIDE = 'R' or 'r' X*op( A ) = alpha*B.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the matrix A 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.
*> \endverbatim
*>
*> \param[in] TRANSA
*> \verbatim
*> TRANSA is CHARACTER*1
*> On entry, TRANSA 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**T.
*>
*> TRANSA = 'C' or 'c' op( A ) = A**H.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> On entry, DIAG 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.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of B. M must be at
*> least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of B. N must be
*> at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha. When alpha is
*> zero then A is not referenced and B need not be set before
*> entry.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, k ),
*> where k is m when SIDE = 'L' or 'l'
*> and k is n when SIDE = 'R' or 'r'.
*> Before entry with UPLO = 'U' or 'u', the leading k by k
*> 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 k by k
*> 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.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA 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 ), when SIDE = 'R' or 'r'
*> then LDA must be at least max( 1, n ).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX array, dimension ( LDB, N )
*> Before entry, the leading m by n part of the array B must
*> contain the right-hand side matrix B, and on exit is
*> overwritten by the solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> On entry, LDB specifies the first dimension of B as declared
*> in the calling (sub) program. LDB must be at least
*> max( 1, m ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level3
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 3 Blas routine.
*>
*> -- Written on 8-February-1989.
*> Jack Dongarra, Argonne National Laboratory.
*> Iain Duff, AERE Harwell.
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
*> Sven Hammarling, Numerical Algorithms Group Ltd.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*
* -- Reference BLAS level3 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA
INTEGER LDA,LDB,M,N
CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),B(LDB,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,MAX
* ..
* .. Local Scalars ..
COMPLEX TEMP
INTEGER I,INFO,J,K,NROWA
LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER
* ..
* .. Parameters ..
COMPLEX ONE
PARAMETER (ONE= (1.0E+0,0.0E+0))
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
*
* Test the input parameters.
*
LSIDE = LSAME(SIDE,'L')
IF (LSIDE) THEN
NROWA = M
ELSE
NROWA = N
END IF
NOCONJ = LSAME(TRANSA,'T')
NOUNIT = LSAME(DIAG,'N')
UPPER = LSAME(UPLO,'U')
*
INFO = 0
IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
INFO = 1
ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
INFO = 2
ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
+ (.NOT.LSAME(TRANSA,'T')) .AND.
+ (.NOT.LSAME(TRANSA,'C'))) THEN
INFO = 3
ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
INFO = 4
ELSE IF (M.LT.0) THEN
INFO = 5
ELSE IF (N.LT.0) THEN
INFO = 6
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 9
ELSE IF (LDB.LT.MAX(1,M)) THEN
INFO = 11
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CTRSM ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF (M.EQ.0 .OR. N.EQ.0) RETURN
*
* And when alpha.eq.zero.
*
IF (ALPHA.EQ.ZERO) THEN
DO 20 J = 1,N
DO 10 I = 1,M
B(I,J) = ZERO
10 CONTINUE
20 CONTINUE
RETURN
END IF
*
* Start the operations.
*
IF (LSIDE) THEN
IF (LSAME(TRANSA,'N')) THEN
*
* Form B := alpha*inv( A )*B.
*
IF (UPPER) THEN
DO 60 J = 1,N
IF (ALPHA.NE.ONE) THEN
DO 30 I = 1,M
B(I,J) = ALPHA*B(I,J)
30 CONTINUE
END IF
DO 50 K = M,1,-1
IF (B(K,J).NE.ZERO) THEN
IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
DO 40 I = 1,K - 1
B(I,J) = B(I,J) - B(K,J)*A(I,K)
40 CONTINUE
END IF
50 CONTINUE
60 CONTINUE
ELSE
DO 100 J = 1,N
IF (ALPHA.NE.ONE) THEN
DO 70 I = 1,M
B(I,J) = ALPHA*B(I,J)
70 CONTINUE
END IF
DO 90 K = 1,M
IF (B(K,J).NE.ZERO) THEN
IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
DO 80 I = K + 1,M
B(I,J) = B(I,J) - B(K,J)*A(I,K)
80 CONTINUE
END IF
90 CONTINUE
100 CONTINUE
END IF
ELSE
*
* Form B := alpha*inv( A**T )*B
* or B := alpha*inv( A**H )*B.
*
IF (UPPER) THEN
DO 140 J = 1,N
DO 130 I = 1,M
TEMP = ALPHA*B(I,J)
IF (NOCONJ) THEN
DO 110 K = 1,I - 1
TEMP = TEMP - A(K,I)*B(K,J)
110 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(I,I)
ELSE
DO 120 K = 1,I - 1
TEMP = TEMP - CONJG(A(K,I))*B(K,J)
120 CONTINUE
IF (NOUNIT) TEMP = TEMP/CONJG(A(I,I))
END IF
B(I,J) = TEMP
130 CONTINUE
140 CONTINUE
ELSE
DO 180 J = 1,N
DO 170 I = M,1,-1
TEMP = ALPHA*B(I,J)
IF (NOCONJ) THEN
DO 150 K = I + 1,M
TEMP = TEMP - A(K,I)*B(K,J)
150 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(I,I)
ELSE
DO 160 K = I + 1,M
TEMP = TEMP - CONJG(A(K,I))*B(K,J)
160 CONTINUE
IF (NOUNIT) TEMP = TEMP/CONJG(A(I,I))
END IF
B(I,J) = TEMP
170 CONTINUE
180 CONTINUE
END IF
END IF
ELSE
IF (LSAME(TRANSA,'N')) THEN
*
* Form B := alpha*B*inv( A ).
*
IF (UPPER) THEN
DO 230 J = 1,N
IF (ALPHA.NE.ONE) THEN
DO 190 I = 1,M
B(I,J) = ALPHA*B(I,J)
190 CONTINUE
END IF
DO 210 K = 1,J - 1
IF (A(K,J).NE.ZERO) THEN
DO 200 I = 1,M
B(I,J) = B(I,J) - A(K,J)*B(I,K)
200 CONTINUE
END IF
210 CONTINUE
IF (NOUNIT) THEN
TEMP = ONE/A(J,J)
DO 220 I = 1,M
B(I,J) = TEMP*B(I,J)
220 CONTINUE
END IF
230 CONTINUE
ELSE
DO 280 J = N,1,-1
IF (ALPHA.NE.ONE) THEN
DO 240 I = 1,M
B(I,J) = ALPHA*B(I,J)
240 CONTINUE
END IF
DO 260 K = J + 1,N
IF (A(K,J).NE.ZERO) THEN
DO 250 I = 1,M
B(I,J) = B(I,J) - A(K,J)*B(I,K)
250 CONTINUE
END IF
260 CONTINUE
IF (NOUNIT) THEN
TEMP = ONE/A(J,J)
DO 270 I = 1,M
B(I,J) = TEMP*B(I,J)
270 CONTINUE
END IF
280 CONTINUE
END IF
ELSE
*
* Form B := alpha*B*inv( A**T )
* or B := alpha*B*inv( A**H ).
*
IF (UPPER) THEN
DO 330 K = N,1,-1
IF (NOUNIT) THEN
IF (NOCONJ) THEN
TEMP = ONE/A(K,K)
ELSE
TEMP = ONE/CONJG(A(K,K))
END IF
DO 290 I = 1,M
B(I,K) = TEMP*B(I,K)
290 CONTINUE
END IF
DO 310 J = 1,K - 1
IF (A(J,K).NE.ZERO) THEN
IF (NOCONJ) THEN
TEMP = A(J,K)
ELSE
TEMP = CONJG(A(J,K))
END IF
DO 300 I = 1,M
B(I,J) = B(I,J) - TEMP*B(I,K)
300 CONTINUE
END IF
310 CONTINUE
IF (ALPHA.NE.ONE) THEN
DO 320 I = 1,M
B(I,K) = ALPHA*B(I,K)
320 CONTINUE
END IF
330 CONTINUE
ELSE
DO 380 K = 1,N
IF (NOUNIT) THEN
IF (NOCONJ) THEN
TEMP = ONE/A(K,K)
ELSE
TEMP = ONE/CONJG(A(K,K))
END IF
DO 340 I = 1,M
B(I,K) = TEMP*B(I,K)
340 CONTINUE
END IF
DO 360 J = K + 1,N
IF (A(J,K).NE.ZERO) THEN
IF (NOCONJ) THEN
TEMP = A(J,K)
ELSE
TEMP = CONJG(A(J,K))
END IF
DO 350 I = 1,M
B(I,J) = B(I,J) - TEMP*B(I,K)
350 CONTINUE
END IF
360 CONTINUE
IF (ALPHA.NE.ONE) THEN
DO 370 I = 1,M
B(I,K) = ALPHA*B(I,K)
370 CONTINUE
END IF
380 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of CTRSM
*
END

372
src/ctrsv.c
View file

@ -1,372 +0,0 @@
*> \brief \b CTRSV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,LDA,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CTRSV solves one of the systems of equations
*>
*> A*x = b, or A**T*x = b, or A**H*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.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO 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.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the equations to be solved as
*> follows:
*>
*> TRANS = 'N' or 'n' A*x = b.
*>
*> TRANS = 'T' or 't' A**T*x = b.
*>
*> TRANS = 'C' or 'c' A**H*x = b.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> On entry, DIAG 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.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, N )
*> 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.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> max( 1, n ).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX array, 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.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INCX,LDA,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),X(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
* .. Local Scalars ..
COMPLEX TEMP
INTEGER I,INFO,IX,J,JX,KX
LOGICAL NOCONJ,NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,MAX
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ .NOT.LSAME(TRANS,'C')) THEN
INFO = 2
ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,N)) THEN
INFO = 6
ELSE IF (INCX.EQ.0) THEN
INFO = 8
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CTRSV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF (N.EQ.0) RETURN
*
NOCONJ = LSAME(TRANS,'T')
NOUNIT = LSAME(DIAG,'N')
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through A.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := inv( A )*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 20 J = N,1,-1
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/A(J,J)
TEMP = X(J)
DO 10 I = J - 1,1,-1
X(I) = X(I) - TEMP*A(I,J)
10 CONTINUE
END IF
20 CONTINUE
ELSE
JX = KX + (N-1)*INCX
DO 40 J = N,1,-1
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
TEMP = X(JX)
IX = JX
DO 30 I = J - 1,1,-1
IX = IX - INCX
X(IX) = X(IX) - TEMP*A(I,J)
30 CONTINUE
END IF
JX = JX - INCX
40 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/A(J,J)
TEMP = X(J)
DO 50 I = J + 1,N
X(I) = X(I) - TEMP*A(I,J)
50 CONTINUE
END IF
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
TEMP = X(JX)
IX = JX
DO 70 I = J + 1,N
IX = IX + INCX
X(IX) = X(IX) - TEMP*A(I,J)
70 CONTINUE
END IF
JX = JX + INCX
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := inv( A**T )*x or x := inv( A**H )*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 110 J = 1,N
TEMP = X(J)
IF (NOCONJ) THEN
DO 90 I = 1,J - 1
TEMP = TEMP - A(I,J)*X(I)
90 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
ELSE
DO 100 I = 1,J - 1
TEMP = TEMP - CONJG(A(I,J))*X(I)
100 CONTINUE
IF (NOUNIT) TEMP = TEMP/CONJG(A(J,J))
END IF
X(J) = TEMP
110 CONTINUE
ELSE
JX = KX
DO 140 J = 1,N
IX = KX
TEMP = X(JX)
IF (NOCONJ) THEN
DO 120 I = 1,J - 1
TEMP = TEMP - A(I,J)*X(IX)
IX = IX + INCX
120 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
ELSE
DO 130 I = 1,J - 1
TEMP = TEMP - CONJG(A(I,J))*X(IX)
IX = IX + INCX
130 CONTINUE
IF (NOUNIT) TEMP = TEMP/CONJG(A(J,J))
END IF
X(JX) = TEMP
JX = JX + INCX
140 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 170 J = N,1,-1
TEMP = X(J)
IF (NOCONJ) THEN
DO 150 I = N,J + 1,-1
TEMP = TEMP - A(I,J)*X(I)
150 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
ELSE
DO 160 I = N,J + 1,-1
TEMP = TEMP - CONJG(A(I,J))*X(I)
160 CONTINUE
IF (NOUNIT) TEMP = TEMP/CONJG(A(J,J))
END IF
X(J) = TEMP
170 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 200 J = N,1,-1
IX = KX
TEMP = X(JX)
IF (NOCONJ) THEN
DO 180 I = N,J + 1,-1
TEMP = TEMP - A(I,J)*X(IX)
IX = IX - INCX
180 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
ELSE
DO 190 I = N,J + 1,-1
TEMP = TEMP - CONJG(A(I,J))*X(IX)
IX = IX - INCX
190 CONTINUE
IF (NOUNIT) TEMP = TEMP/CONJG(A(J,J))
END IF
X(JX) = TEMP
JX = JX - INCX
200 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of CTRSV
*
END

60
src/lsame.c
View file

@ -53,7 +53,7 @@
*
* =====================================================================
*/
bool lsame ( char ca, char cb ) {
bool lsame(char ca, char cb) {
// -- Reference BLAS level1 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
@ -61,24 +61,56 @@ bool lsame ( char ca, char cb ) {
// =====================================================================
// Test if the characters are equal
// .. Local Scalars ..
int inta, intb, zcode;
if ( ca == cb ) {
// Test if the characters are equal
if (ca == cb) {
return true;
}
if ( 'A' <= ca && ca <= 'Z' ) {
if ( ca - 'A' == cb - 'a' ) {
return true;
// Now test for equivalence if both characters are alphabetic.
zcode = (int)'Z';
// Use 'Z' rather than 'A' so that ASCII can be detected on Prime
// machines, on which ICHAR returns a value with bit 8 set.
// ICHAR('A') on Prime machines returns 193 which is the same as
// ICHAR('A') on an EBCDIC machine.
inta = (int)ca;
intb = (int)cb;
if (zcode == 90 || zcode == 122) {
// ASCII is assumed - ZCODE is the ASCII code of either lower or
// upper case 'Z'.
if (inta >= 97 && inta <= 122) {
inta = inta - 32;
}
} else if ( 'a' <= ca && ca <= 'z' ) {
if ( ca - 'a' == cb - 'A' ) {
return true;
if (intb >= 97 && intb <= 122) {
intb = intb - 32;
}
} else if (zcode == 233 || zcode == 169) {
// EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
// upper case 'Z'.
if ((inta >= 129 && inta <= 137) ||
(inta >= 145 && inta <= 153) ||
(inta >= 162 && inta <= 169)) {
inta = inta + 64;
}
if ((intb >= 129 && intb <= 137) ||
(intb >= 145 && intb <= 153) ||
(intb >= 162 && intb <= 169)) {
intb = intb + 64;
}
} else if (zcode == 218 || zcode == 250) {
// ASCII is assumed, on Prime machines - ZCODE is the ASCII code
// plus 128 of either lower or upper case 'Z'.
if (inta >= 225 && inta <= 250) {
inta = inta - 32;
}
if (intb >= 225 && intb <= 250) {
intb = intb - 32;
}
}
return false;
// End of LSAME
}
return inta == intb;
}

47
src/caxpy.c → src/single/caxpy.c
View file

@ -1,6 +1,6 @@
#include <complex.h>
#include "blas.h"
#include "blas_internal.h"
/*
*> \brief \b CAXPY
@ -90,49 +90,34 @@
*>
* =====================================================================
*/
void caxpy ( int n, float complex ca, float complex cx[], int incx,
float complex cy[], int incy ) {
//
void caxpy(int n, complex float ca, complex float *cx, int incx, complex float *cy, int incy) {
// -- Reference BLAS level1 routine (version 3.4.0) --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// November 2011
//
int i, ix, iy;
if ( n <= 0 ) return;
if ( scabs1 ( ca ) == 0.0 ) return;
if ( incx != 1 || incy != 1 ) {
if ( 0 <= incx ) {
ix = 0;
if (n <= 0) return;
if (scabs1(ca) == 0.0) return;
if (incx == 1 && incy == 1) {
for (i = 0; i < n; i++) {
cy[i] = cy[i] + ca * cx[i];
}
else {
ix = ( -n + 1 ) * incx;
}
if ( 0 <= incy ) {
iy = 0;
}
else {
iy = ( -n + 1 ) * incy;
}
} else {
ix = 0;
iy = 0;
if (incx < 0)
ix = (-n + 1) * incx;
if (incy < 0)
iy = (-n + 1) * incy;
for (i = 0; i < n; i++) {
cy[iy] = cy[iy] + ca * cx[ix];
ix = ix + incx;
iy = iy + incy;
}
}
else {
for (i = 0; i < n; i++) {
cy[i] = cy[i] + ca * cx[i];
}
}
return;
// End of CAXPY

66
src/ccopy.c → src/single/ccopy.c
View file

@ -1,7 +1,5 @@
#include <complex.h>
#include "blas.h"
/*
*> \brief \b CCOPY
*
@ -83,8 +81,7 @@
*>
* =====================================================================
*/
void ccopy ( int n, float complex cx[], int incx, float complex cy[],
int incy ) {
void ccopy(int n, complex float *cx, int incx, complex float *cy, int incy) {
// -- Reference BLAS level1 routine (version 3.4.0) --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
@ -93,35 +90,46 @@ void ccopy ( int n, float complex cx[], int incx, float complex cy[],
int i, ix, iy;
if ( n <= 0 ) {
return;
}
if (n <= 0) return;
if ( incx != 1 || incy != 1 ) {
if ( 0 <= incx ) {
if (incx == 1 && incy == 1) {
for (i = 0; i < n; i++) {
cy[i] = cx[i];
}
} else {
ix = 0;
} else {
ix = ( -n + 1 ) * incx;
}
if ( 0 <= incy ) {
iy = 0;
} else {
iy = ( -n + 1 ) * incy;
}
for ( i = 0; i < n; i++ ) {
cy[iy] = cx[ix];
ix = ix + incx;
iy = iy + incy;
}
} else {
for ( i = 0; i < n; i++ ) {
cy[i] = cx[i];
}
}
return;
if (incx < 0) ix = (-n + 1) * incx;
if (incy < 0) iy = (-n + 1) * incy;
for (i = 0; i < n; i++) {
cy[iy] = cx[ix];
ix += incx;
iy += incy;
}
}
// End of CCOPY
}
/*
#include <stdio.h>
int main() {
// test the ccopy function
int n = 5;
complex float cx[] = {1.0 + 2.0i, 2.0 + 3.0i, 3.0 + 4.0i, 4.0 + 5.0i, 5.0 + 6.0i};
complex float cy[n];
int incx = 1;
int incy = 1;
ccopy(n, cx, incx, cy, incy);
printf("cy: ");
for (int i = 0; i < n; i++) {
printf("%.1f + %.1fi ", creal(cy[i]), cimag(cy[i]));
}
printf("\n");
return 0;
}
*/

48
src/cdotc.c → src/single/cdotc.c
View file

@ -1,7 +1,5 @@
#include <complex.h>
#include "blas.h"
/*
*> \brief \b CDOTC
*
@ -85,49 +83,37 @@
*>
* =====================================================================
*/
float complex cdotc ( int n, float complex cx[], int incx,
float complex cy[], int incy ) {
complex float cdotc(int n, complex float *cx, int incx, complex float *cy, int incy) {
// -- Reference BLAS level1 routine (version 3.4.0) --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// November 2011
int i, ix, iy;
float complex value;
complex float ctemp = 0.0 + 0.0 * I;
complex float cdotc = 0.0 + 0.0 * I;
value = 0.0;
if (n <= 0) return cdotc;
if ( n <= 0 ) {
return value;
}
if ( incx == 1 && incy == 1 ) {
for ( i = 0; i < n; i++ ) {
value = value + ( ~cx[i] ) * cy[i];
if (incx == 1 && incy == 1) {
for (i = 0; i < n; i++) {
ctemp += conjf(cx[i]) * cy[i];
}
} else {
if ( 0 <= incx ) {
ix = 0;
} else {
ix = ( -n + 1 ) * incx;
}
if ( 0 <= incy ) {
iy = 0;
} else {
iy = ( -n + 1 ) * incy;
}
for ( i = 0; i < n; i++ ) {
value = value + ( ~cx[ix] ) * cy[iy];
ix = ix + incx;
iy = iy + incy;
ix = 0;
iy = 0;
if (incx < 0) ix = (-n + 1) * incx;
if (incy < 0) iy = (-n + 1) * incy;
for (i = 0; i < n; i++) {
ctemp += conjf(cx[ix]) * cy[iy];
ix += incx;
iy += incy;
}
}
return value;
cdotc = ctemp;
return cdotc;
// End of CDOTC

49
src/cdotu.c → src/single/cdotu.c
View file

@ -1,7 +1,5 @@
#include <complex.h>
#include "blas.h"
/*
*> \brief \b CDOTU
*
@ -85,49 +83,36 @@
*>
* =====================================================================
*/
float complex cdotu ( int n, float complex cx[], int incx,
float complex cy[], int incy ) {
complex float cdotu(int n, complex float* cx, int incx, complex float *cy, int incy) {
// -- Reference BLAS level1 routine (version 3.4.0) --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// November 2011
int i, ix, iy;
float complex value;
complex double ctemp = 0.0 + 0.0*I;
if (n <= 0) return ctemp;
value = 0.0;
if ( n <= 0 ) {
return value;
}
if ( incx == 1 && incy == 1 ) {
for ( i = 0; i < n; i++ ) {
value = value + cx[i] * cy[i];
if (incx == 1 && incy == 1) {
// code for both increments equal to 1
for (i = 0; i < n; i++) {
ctemp += cx[i] * cy[i];
}
} else {
if ( 0 <= incx ) {
ix = 0;
} else {
ix = ( -n + 1 ) * incx;
}
if ( 0 <= incy ) {
iy = 0;
} else {
iy = ( -n + 1 ) * incy;
}
for ( i = 0; i < n; i++ ) {
value = value + cx[ix] * cy[iy];
ix = ix + incx;
iy = iy + incy;
// code for unequal increments or equal increments not equal to 1
ix = 0;
iy = 0;
if (incx < 0) ix = (-n+1)*incx;
if (incy < 0) iy = (-n+1)*incy;
for (i = 0; i < n; i++) {
ctemp += cx[ix] * cy[iy];
ix += incx;
iy += incy;
}
}
return value;
return ctemp;
// End of CDOTU

356
src/single/cgbmv.c Normal file
View file

@ -0,0 +1,356 @@
#include <math.h>
#include <complex.h>
#include <stdbool.h>
#include "blas_internal.h"
/*
*> \brief \b CGBMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA,BETA
* INTEGER INCX,INCY,KL,KU,LDA,M,N
* CHARACTER TRANS
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CGBMV performs one of the matrix-vector operations
*>
*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or
*>
*> y := alpha*A**H*x + beta*y,
*>
*> where alpha and beta are scalars, x and y are vectors and A is an
*> m by n band matrix, with kl sub-diagonals and ku super-diagonals.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS 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**T*x + beta*y.
*>
*> TRANS = 'C' or 'c' y := alpha*A**H*x + beta*y.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of the matrix A.
*> M must be at least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*> KL is INTEGER
*> On entry, KL specifies the number of sub-diagonals of the
*> matrix A. KL must satisfy 0 .le. KL.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> On entry, KU specifies the number of super-diagonals of the
*> matrix A. KU must satisfy 0 .le. KU.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, N )
*> Before entry, the leading ( kl + ku + 1 ) by n part of the
*> array A must contain the matrix of coefficients, supplied
*> column by column, with the leading diagonal of the matrix in
*> row ( ku + 1 ) of the array, the first super-diagonal
*> starting at position 2 in row ku, the first sub-diagonal
*> starting at position 1 in row ( ku + 2 ), and so on.
*> Elements in the array A that do not correspond to elements
*> in the band matrix (such as the top left ku by ku triangle)
*> are not referenced.
*> The following program segment will transfer a band matrix
*> from conventional full matrix storage to band storage:
*>
*> DO 20, J = 1, N
*> K = KU + 1 - J
*> DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL )
*> A( K + I, J ) = matrix( I, J )
*> 10 CONTINUE
*> 20 CONTINUE
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> ( kl + ku + 1 ).
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX array, 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.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is COMPLEX
*> On entry, BETA specifies the scalar beta. When BETA is
*> supplied as zero then Y need not be set on input.
*> \endverbatim
*>
*> \param[in,out] Y
*> \verbatim
*> Y is COMPLEX array, dimension at least
*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
*> and at least
*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
*> Before entry, the incremented array Y must contain the
*> vector y. On exit, Y is overwritten by the updated vector y.
*> If either m or n is zero, then Y not referenced and the function
*> performs a quick return.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
*/
void cgbmv(char trans, int m, int n, int kl, int ku, complex float alpha, complex float *a, int lda, complex float *x, int incx, complex float beta, complex float *y, int incy) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float one = CMPLXF(1.0, 0.0);
complex float zero = CMPLXF(0.0, 0.0);
complex float temp;
int i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny;
bool noconj = (trans == 'T');
// Test the input parameters.
info = 0;
if (trans != 'N' && trans != 'T' && trans != 'C') {
info = 1;
} else if (m < 0) {
info = 2;
} else if (n < 0) {
info = 3;
} else if (kl < 0) {
info = 4;
} else if (ku < 0) {
info = 5;
} else if (lda < (kl + ku + 1)) {
info = 8;
} else if (incx == 0) {
info = 10;
} else if (incy == 0) {
info = 13;
}
if (info != 0) {
xerbla("CGBMV ", info);
return;
}
// Quick return if possible.
if (m == 0 || n == 0 || (alpha == 0.0 && beta == 1.0)) return;
// Set LENX and LENY, the lengths of the vectors x and y, and set up the start points in X and Y.
if (trans == 'N') {
lenx = n;
leny = m;
} else {
lenx = m;
leny = n;
}
if (incx > 0) {
kx = 0;
} else {
kx = 0 - (lenx - 1) * incx;
}
if (incy > 0) {
ky = 0;
} else {
ky = 0 - (leny - 1) * incy;
}
// Start the operations. In this version the elements of A are accessed sequentially with one pass through the band part of A.
// First form y := beta*y.
if (cabs(beta) != 1.0) {
if (incy == 1) {
if (cabs(beta) == 0.0) {
for (i = 0; i < leny; i++) {
y[i] = zero;
}
} else {
for (i = 0; i < leny; i++) {
y[i] = beta * y[i];
}
}
} else {
iy = ky;
if (cabs(beta) == 0.0) {
for (i = 0; i < leny; i++) {
y[iy] = zero;
iy += incy;
}
} else {
for (i = 0; i < leny; i++) {
y[iy] = beta * y[iy];
iy += incy;
}
}
}
}
if (cabs(alpha) == 0.0) return;
kup1 = ku + 1;
if (trans == 'N') {
// Form y := alpha*A*x + y.
jx = kx;
if (incy == 1) {
for (j = 0; j < n; j++) {
temp = alpha * x[jx];
k = kup1 - j;
for (i = fmax(0, j - ku); i < fmin(m, j + kl); i++) {
y[i] = y[i] + temp * a[k + i + j * lda];
}
jx += incx;
}
} else {
jx = kx;
for (j = 0; j < n; j++) {
temp = alpha * x[jx];
iy = ky;
k = kup1 - j;
for (i = fmax(0, j - ku); i < fmin(m, j + kl); i++) {
y[iy] = y[iy] + temp * a[k + i + j * lda];
iy += incy;
}
jx += incx;
if (j > ku) ky += incy;
}
}
} else {
// Form y := alpha*A**T*x + y or y := alpha*A**H*x + y.
jy = ky;
if (incx == 1) {
for (j = 0; j < n; j++) {
temp = zero;
k = kup1 - j;
if (noconj) {
for (i = fmax(0, j - ku); i < fmin(m, j + kl); i++) {
temp = temp + a[k + i + j * lda] * x[i];
}
} else {
for (i = fmax(0, j - ku); i < fmin(m, j + kl); i++) {
temp = temp + conj(a[k + i + j * lda]) * x[i];
}
}
y[jy] = y[jy] + alpha * temp;
jy += incy;
}
} else {
jy = ky;
for (j = 0; j < n; j++) {
temp = zero;
ix = kx;
k = kup1 - j;
if (noconj) {
for (i = fmax(0, j - ku); i < fmin(m, j + kl); i++) {
temp = temp + a[k + i + j * lda] * x[ix];
ix += incx;
}
} else {
for (i = fmax(0, j - ku); i < fmin(m, j + kl); i++) {
temp = temp + conj(a[k + i + j * lda]) * x[ix];
ix += incx;
}
}
y[jy] = y[jy] + alpha * temp;
jy += incy;
if (j > ku) kx += incx;
}
}
}
}

389
src/cgemm.c → src/single/cgemm.c
View file

@ -1,9 +1,8 @@
#include <stdio.h>
#include <stdlib.h>
#include <math.h>
#include <complex.h>
#include <stdbool.h>
#include "blas.h"
#include "blas_internal.h"
/*
*> \brief \b CGEMM
@ -192,9 +191,7 @@
*>
* =====================================================================
*/
void cgemm(char transa, char transb, int m, int n, int k, complex float alpha,
complex float a[], int lda, complex float b[], int ldb, complex float beta,
complex float c[], int ldc) {
void cgemm(char transa, char transb, int m, int n, int k, complex float alpha, complex float *a, int lda, complex float *b, int ldb, complex float beta, complex float *c, int ldc) {
// -- Reference BLAS level3 routine (version 3.4.0) --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
@ -202,308 +199,250 @@ void cgemm(char transa, char transb, int m, int n, int k, complex float alpha,
// November 2011
// Local Scalars ..
int i, j, l, nrowa, nrowb, info, ncola;
int i, info, j, l, nrowa, nrowb;
complex float temp;
bool conja, conjb, nota, notb;
complex float one = (1.0e0, 0.0e0);
complex float zero = (0.0e0, 0.0e0);
complex float one = CMPLXF(1.0e0, 0.0e0);
complex float zero = CMPLXF(0.0e0, 0.0e0);
// Set NOTA and NOTB as true if A and B respectively are not
// conjugated or transposed, set CONJA and CONJB as true if A and
// B respectively are to be transposed but not conjugated and set
// NROWA, NCOLA and NROWB as the number of rows and columns of A
// and the number of rows of B respectively.
/* Set NOTA and NOTB as true if A and B respectively are not
conjugated or transposed, set CONJA and CONJB as true if A and
B respectively are to be transposed but not conjugated and set
NROWA, NCOLA and NROWB as the number of rows and columns of A
and the number of rows of B respectively. */
nota = ( ( transa == 'N' ) || ( transa == 'n' ) );
notb = ( ( transb == 'N' ) || ( transb == 'n' ) );
conja = ( ( transa == 'C' ) || ( transa == 'c' ) );
conjb = ( ( transb == 'C' ) || ( transb == 'c' ) );
nota = (transa == 'N' || transa == 'n');
notb = (transb == 'N' || transb == 'n');
conja = (transa == 'C' || transa == 'c');
conjb = (transb == 'C' || transb == 'c');
if ( nota ) {
nrowa = m;
ncola = k;
}
else {
nrowa = k;
ncola = m;
}
if (notb) {
nrowb = k;
}
else {
nrowb = n;
}
// Test the input parameters.
nrowa = (nota) ? m : k;
nrowb = (notb) ? k : n;
// Test the input parameters.
info = 0;
if ( ! ( transa == 'N' || transa == 'n' ||
transa == 'C' || transa == 'c' ||
transa == 'T' || transa == 't' ) ) {
if ((!nota && !conja && (transa == 'T' || transa == 't'))) {
info = 1;
}
if ( ! ( transb == 'N' || transb == 'n' ||
transb == 'C' || transb == 'c' ||
transb == 'T' || transb == 't' ) ) {
} else if (!notb && !conjb && (transb == 'T' || transb == 't')) {
info = 2;
}
if ( m < 0 ) {
} else if (m < 0) {
info = 3;
}
else if ( n < 0 ) {
} else if (n < 0) {
info = 4;
}
else if ( k < 0 ) {
} else if (k < 0) {
info = 5;
}
else if ( lda < i4_max( 1, nrowa ) ) {
} else if (lda < fmax(1, nrowa)) {
info = 8;
}
else if ( ldb < i4_max( 1, nrowb ) ) {
} else if (ldb < fmax(1, nrowb)) {
info = 10;
}
else if ( ldc < i4_max( 1, m ) ) {
} else if (ldc < fmax(1, m)) {
info = 13;
}
if (info != 0) {
xerbla('cgemm ', info);
xerbla("CGEMM ", info);
return;
}
// Quick return if possible.
// Quick return if possible.
if ((m == 0) || (n == 0) || (((alpha == zero) || (k == 0)) && (beta == one))) return;
if (( m == 0 ) || (n == 0) || (((alpha == zero) || ( k == 0 )) && ( beta == one ) ) ) {
return;
}
// And when alpha.eq.zero.
if ( alpha == zero ) {
if ( beta == zero ) {
for ( j = 0; j < n; j++ ) {
for ( i = 0; i < m; i++ ) {
c[i+j*ldc] = zero;
// And when alpha = 0.
if (alpha == zero) {
if (beta == zero) {
for (j = 0; j < n; j++) {
for (i = 0; i < m; i++) {
c[i + j * ldc] = zero;
}
}
}
else {
for ( j = 0; j < n; j++ ) {
for ( i = 0; i < m; i++ ) {
c[i+j*ldc] = beta * c[i+j*ldc];
} else {
for (j = 0; j < n; j++) {
for (i = 0; i < m; i++) {
c[i + j * ldc] *= beta;
}
}
}
return;
}
// Start the operations.
// Start the operations.
if (notb) {
if (nota) {
if ( notb ) {
if ( nota ) {
// Form C := alpha*A*B + beta*C.
// Form C := alpha*A*B + beta*C.
for ( j = 0; j < n; j++ ) {
if ( beta == zero ) {
for ( i = 0; i < m; i++ ) {
c[i+j*ldc] = zero;
}
}
else if ( beta != one ) {
for ( i = 0; i < m; i++ ) {
c[i+j*ldc] = beta*c[i+j*ldc];
}
}
for ( l = 0; l < k; l++ ) {
if ( b[l+j*ldb] != zero ) {
temp = alpha * b[l+j*ldb];
for ( i = 0; i < m; i++ ) {
c[i+j*ldc] = c[i+j*ldc] + temp * a[i+l*lda];
}
}
}
}
}
else if (conja) {
// Form C := alpha*A**H*B + beta*C.
for ( j = 0; j < n; j++ ) {
for ( i = 0; i < m; i++ ) {
temp = zero;
for ( l = 0; l < k; l++ ) {
temp = temp + (~a[l+i*lda])* b[l+j*ldb];
}
if (beta == zero) {
c[i+j*ldc] = alpha*temp;
}
else {
c[i+j*ldc] = alpha*temp + beta*c[i+j*ldc];
}
}
}
}
else {
// Form C := alpha*A**T*B + beta*C
for ( j = 0; j < n; j++ ) {
for ( i = 0; i < m; i++ ) {
temp = zero;
for ( l = 0; l < k; l++ ) {
temp = temp + a[l+i*lda] * b[l+j*ldb];
}
if (beta == zero) {
c[i+j*ldc] = alpha*temp;
}
else {
c[i+j*ldc] = alpha*temp + beta*c[i+j*ldc];
}
}
}
}
}
else if (nota) {
if (conjb) {
// Form C := alpha*A*B**H + beta*C.
for ( j = 0; j < n; j++ ) {
for (j = 0; j < n; j++) {
if (beta == zero) {
for ( i = 0; i < m; i++ ) {
c[i+j*ldc] = zero;
for (i = 0; i < m; i++) {
c[i + j * ldc] = zero;
}
} else if (beta != one) {
for (i = 0; i < m; i++) {
c[i + j * ldc] *= beta;
}
}
else if (beta != one) {
for ( i = 0; i < m; i++ ) {
c[i+j*ldc] = beta*c[i+j*ldc];
for (l = 0; l < k; l++) {
temp = alpha * b[l + j * ldb];
for (i = 0; i < m; i++) {
c[i + j * ldc] += temp * a[i + l * lda];
}
}
for ( l = 0; l < k; l++ ) {
if (b[j+l*ldb] != zero) {
temp = alpha*(~b[j+l*ldb]);
for ( i = 0; i < m; i++ ) {
c[i+j*ldc] = c[i+j*ldc] + temp*a[i+l*lda];
}
}
} else if (conja) {
// Form C := alpha*A**H*B + beta*C.
for (j = 0; j < n; j++) {
for (i = 0; i < m; i++) {
temp = zero;
for (l = 0; l < k; l++) {
temp += conj(a[l + i * lda]) * b[l + j * ldb];
}
if (beta == zero) {
c[i + j * ldc] = alpha * temp;
} else {
c[i + j * ldc] = alpha * temp + beta * c[i + j * ldc];
}
}
}
} else {
// Form C := alpha*A**T*B + beta*C.
for (j = 0; j < n; j++) {
for (i = 0; i < m; i++) {
temp = zero;
for (l = 0; l < k; l++) {
temp += a[l + i * lda] * b[l + j * ldb];
}
if (beta == zero) {
c[i + j * ldc] = alpha * temp;
} else {
c[i + j * ldc] = alpha * temp + beta * c[i + j * ldc];
}
}
}
}
else {
} else if (nota) {
if (conjb) {
// Form C := alpha*A*B**T + beta*C
// Form C := alpha*A*B**H + beta*C.
for ( j = 0; j < n; j++ ) {
for (j = 0; j < n; j++) {
if (beta == zero) {
for ( i = 0; i < m; i++ ) {
c[i+j*ldc] = zero;
for (i = 0; i < m; i++) {
c[i + j * ldc] = zero;
}
} else if (beta != one) {
for (i = 0; i < m; i++) {
c[i + j * ldc] *= beta;
}
}
else if (beta != one) {
for ( i = 0; i < m; i++ ) {
c[i+j*ldc] = beta*c[i+j*ldc];
for (l = 0; l < k; l++) {
temp = alpha * conj(b[j + l * ldb]);
for (i = 0; i < m; i++) {
c[i + j * ldc] += temp * a[i + l * lda];
}
}
for ( l = 0; l < k; l++ ) {
if (b[j+l*ldb] != zero) {
temp = alpha*b[j+l*ldb];
for ( i = 0; i < m; i++ ) {
c[i+j*ldc] = c[i+j*ldc] + temp*a[i+l*lda];
}
}
} else {
// Form C := alpha*A*B**T + beta*C.
for (j = 0; j < n; j++) {
if (beta == zero) {
for (i = 0; i < m; i++) {
c[i + j * ldc] = zero;
}
} else if (beta != one) {
for (i = 0; i < m; i++) {
c[i + j * ldc] *= beta;
}
}
for (l = 0; l < k; l++) {
temp = alpha * b[j + l * ldb];
for (i = 0; i < m; i++) {
c[i + j * ldc] += temp * a[i + l * lda];
}
}
}
}
}
else if (conja) {
} else if (conja) {
if (conjb) {
// Form C := alpha*A**H*B**H + beta*C.
// Form C := alpha*A**H*B**H + beta*C.
for ( j = 0; j < n; j++ ) {
for ( i = 0; i < m; i++ ) {
for (j = 0; j < n; j++) {
for (i = 0; i < m; i++) {
temp = zero;
for ( l = 0; l < k; l++ ) {
temp = temp + (~a[l+i*lda])*(~b[j+l*ldb]);
for (l = 0; l < k; l++) {
temp += conj(a[l + i * lda]) * conj(b[j + l * ldb]);
}
if (beta == zero) {
c[i+j*ldc] = alpha*temp;
c[i + j * ldc] = alpha * temp;
} else {
c[i + j * ldc] = alpha * temp + beta * c[i + j * ldc];
}
else {
c[i+j*ldc] = alpha*temp + beta*c[i+j*ldc];
}
}
} else {
// Form C := alpha*A**H*B**T + beta*C.
for (j = 0; j < n; j++) {
for (i = 0; i < m; i++) {
temp = zero;
for (l = 0; l < k; l++) {
temp += conj(a[l + i * lda]) * b[j + l * ldb];
}
if (beta == zero) {
c[i + j * ldc] = alpha * temp;
} else {
c[i + j * ldc] = alpha * temp + beta * c[i + j * ldc];
}
}
}
}
else {
// Form C := alpha*A**H*B**T + beta*C
for ( j = 0; j < n; j++ ) {
for ( i = 0; i < m; i++ ) {
temp = zero;
for ( l = 0; l < k; l++ ) {
temp = temp + (~a[l+i*lda])*b[j+l*ldb];
}
if (beta == zero) {
c[i+j*ldc] = alpha*temp;
}
else {
c[i+j*ldc] = alpha*temp + beta*c[i+j*ldc];
}
}
}
}
}
else {
} else {
if (conjb) {
// Form C := alpha*A**T*B**H + beta*C
// Form C := alpha*A**T*B**H + beta*C.
for ( j = 0; j < n; j++ ) {
for ( i = 0; i < m; i++ ) {
for (j = 0; j < n; j++) {
for (i = 0; i < m; i++) {
temp = zero;
for ( l = 0; l < k; l++ ) {
temp = temp + a[l+i*lda]*(~b[j+l*ldb]);
for (l = 0; l < k; l++) {
temp += a[l + i * lda] * conj(b[j + l * ldb]);
}
if (beta == zero) {
c[i+j*ldc] = alpha*temp;
}
else {
c[i+j*ldc] = alpha*temp + beta*c[i+j*ldc];
c[i + j * ldc] = alpha * temp;
} else {
c[i + j * ldc] = alpha * temp + beta * c[i + j * ldc];
}
}
}
}
else {
} else {
// Form C := alpha*A**T*B**T + beta*C
// Form C := alpha*A**T*B**T + beta*C.
for ( j = 0; j < n; j++ ) {
for ( i = 0; i < m; i++ ) {
for (j = 0; j < n; j++) {
for (i = 0; i < m; i++) {
temp = zero;
for ( l = 0; l < k; l++ ) {
temp = temp + a[l+i*lda]*b[j+l*ldb];
for (l = 0; l < k; l++) {
temp += a[l + i * lda] * b[j + l * ldb];
}
if (beta == zero) {
c[i+j*ldc] = alpha*temp;
}
else {
c[i+j*ldc] = alpha*temp + beta*c[i+j*ldc];
c[i + j * ldc] = alpha * temp;
} else {
c[i + j * ldc] = alpha * temp + beta * c[i + j * ldc];
}
}
}
}
}
return;
// End of CGEMM .
}
}

147
src/cgemv.c → src/single/cgemv.c
View file

@ -1,7 +1,8 @@
#include <math.h>
#include <complex.h>
#include <stdbool.h>
#include "blas.h"
#include "blas_internal.h"
/*
*> \brief \b CGEMV
@ -125,6 +126,8 @@
*> 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.
*> If either m or n is zero, then Y not referenced and the function
*> performs a quick return.
*> \endverbatim
*>
*> \param[in] INCY
@ -161,64 +164,50 @@
*>
* =====================================================================
*/
void cgemv(char trans, int m, int n, complex float alpha, complex float a[], int lda, complex float x[], int incx, complex float beta, complex float y[], int incy) {
void cgemv(char trans, int m, int n, complex float alpha, complex float *a, int lda, complex float *x, int incx, complex float beta, complex float *y, int incy) {
// -- Reference BLAS level2 routine (version 3.4.0) --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// November 2011
// ..
// =====================================================================
// .. Parameters ..
complex float one = (1.0E+0,0.0E+0 * I);
complex float zero = (0.0E+0,0.0E+0 * I);
// ..
// .. Local Scalars ..
complex float temp;
int i,info,ix,iy,j,jx,jy,kx,ky,lenx,leny;
bool noconj;
// ..
// Test the input parameters.
// Test the input parameters
info = 0;
if (!lsame(trans,'N') && !lsame(trans,'T') &&
+ !lsame(trans,'C')) {
if (trans != 'N' && trans != 'T' && trans != 'C') {
info = 1;
} else if (m < 0) {
} else if (m < 0) {
info = 2;
} else if (n < 0) {
} else if (n < 0) {
info = 3;
} else if (lda < MAX(1,m)) {
} else if (lda < fmax(1, m)) {
info = 6;
} else if (incx == 0) {
} else if (incx == 0) {
info = 8;
} else if (incy == 0) {
} else if (incy == 0) {
info = 11;
}
if (info != 0) {
xerbla('CGEMV ',info);
xerbla("CGEMV ",info);
return;
}
// Quick return if possible.
if ((m == 0) || (n == 0) ||
((alpha == zero) && (beta == one))) {
return;
// Quick return if possible
if (m == 0 || n == 0 || (alpha == 0 && beta == 1)) {
return;
}
noconj = lsame(trans,'T');
noconj = (trans == 'T');
// Set LENX and LENY, the lengths of the vectors x and y, and set
// up the start points in X and Y.
// Set LENX and LENY, the lengths of the vectors x and y, and set up the start points in X and Y
if (lsame(trans,'N')) {
if (trans == 'N') {
lenx = n;
leny = m;
} else {
@ -228,117 +217,111 @@ void cgemv(char trans, int m, int n, complex float alpha, complex float a[], int
if (incx > 0) {
kx = 0;
} else {
kx = 0 - (lenx-1)*incx;
kx = 0 - (lenx - 1) * incx;
}
if (incy > 0) {
ky = 0;
} else {
ky = 0 - (leny-1)*incy;
ky = 0 - (leny - 1) * incy;
}
// Start the operations. In this version the elements of A are
// accessed sequentially with one pass through A.
// Start the operations. In this version, the elements of A are accessed sequentially with one pass through A.
// First form y := beta*y.
if (beta != one) {
// First form y := beta * y
if (beta != 1) {
if (incy == 1) {
if (beta == zero) {
for ( i = 0; i < leny; i++) {
y[i] = zero;
if (beta == 0) {
for (i = 0; i < leny; i++) {
y[i] = 0;
}
} else {
for ( i = 0; i < leny; i++) {
y[i] = beta*y[i];
for (i = 0; i < leny; i++) {
y[i] = beta * y[i];
}
}
} else {
iy = ky;
if (beta == zero) {
for ( i = 0; i < leny; i++) {
y[iy] = zero;
if (beta == 0) {
for (i = 0; i < leny; i++) {
y[iy] = 0;
iy = iy + incy;
}
} else {
for ( i = 0; i < leny; i++) {
y[iy] = beta*y[iy];
for (i = 0; i < leny; i++) {
y[iy] = beta * y[iy];
iy = iy + incy;
}
}
}
}
if (alpha == zero) {return;}
if (lsame(trans,'N')) {
// Form y := alpha*A*x + y.
if (alpha == 0) return;
if (trans == 'N') {
// Form y := alpha * A * x + y
jx = kx;
if (incy == 1) {
for ( j = 0; j < n; j++) {
if (x[jx] != zero) {
temp = alpha*x[jx];
for ( i = 0; i < m; i++) {
y[i] = y[i] + temp*a[i+j*lda];
}
for (j = 0; j < n; j++) {
temp = alpha * x[jx];
for (i = 0; i < m; i++) {
y[i] = y[i] + temp * a[i * lda + j];
}
jx = jx + incx;
}
} else {
for ( j = 0; j < n; j++) {
if (x[jx] != zero) {
temp = alpha*x[jx];
iy = ky;
for ( i = 0; i < m; i++) {
y[iy] = y[iy] + temp*a[i+j*lda];
iy = iy + incy;
}
for (j = 0; j < n; j++) {
temp = alpha * x[jx];
iy = ky;
for (i = 0; i < m; i++) {
y[iy] = y[iy] + temp * a[i * lda + j];
iy = iy + incy;
}
jx = jx + incx;
}
}
} else {
// Form y := alpha*A**T*x + y or y := alpha*A**H*x + y.
// Form y := alpha * A^T * x + y or y := alpha * A^H * x + y
jy = ky;
if (incx == 1) {
for ( j = 0; j < n; j++) {
temp = zero;
for (j = 0; j < n; j++) {
temp = 0;
if (noconj) {
for ( i = 0; i < m; i++) {
temp = temp + a[i+j*lda]*x[i];
for (i = 0; i < m; i++) {
temp = temp + a[i * lda + j] * x[i];
}
} else {
for ( i = 0; i < m; i++) {
temp = temp + (~a[i+j*lda])*x[i];
for (i = 0; i < m; i++) {
temp = temp + conj(a[i * lda + j]) * x[i];
}
}
y[jy] = y[jy] + alpha*temp;
y[jy] = y[jy] + alpha * temp;
jy = jy + incy;
}
} else {
for ( j = 0; j < n; j++) {
temp = zero;
for (j = 0; j < n; j++) {
temp = 0;
ix = kx;
if (noconj) {
for ( i = 0; i < m; i++) {
temp = temp + a[i+j*lda]*x[ix];
for (i = 0; i < m; i++) {
temp = temp + a[i * lda + j] * x[ix];
ix = ix + incx;
}
} else {
for ( i = 0; i < m; i++) {
temp = temp + (~a[i+j*lda])*x[ix];
for (i = 0; i < m; i++) {
temp = temp + conj(a[i * lda + j]) * x[ix];
ix = ix + incx;
}
}
y[jy] = y[jy] + alpha*temp;
y[jy] = y[jy] + alpha * temp;
jy = jy + incy;
}
}
}
return;
// End of CGEMV .
}
}

61
src/cgerc.c → src/single/cgerc.c
View file

@ -1,6 +1,7 @@
#include <math.h>
#include <complex.h>
#include "blas.h"
#include "blas_internal.h"
/*
*> \brief \b CGERC
@ -132,8 +133,7 @@
*>
* =====================================================================
*/
void cgerc(int m, int n, complex float alpha, complex float x[], int incx,
complex float y[], int incy, complex float a[], int lda) {
void cgerc(int m, int n, complex float alpha, complex float *x, int incx, complex float *y, int incy, complex float *a, int lda) {
// -- Reference BLAS level2 routine (version 3.4.0) --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
@ -143,14 +143,13 @@ void cgerc(int m, int n, complex float alpha, complex float x[], int incx,
// =====================================================================
// .. Parameters ..
complex float zero = (0.0E+0, 0.0E+0 * I);
complex float zero = 0.0 + 0.0 * I;
// .. Local Scalars ..
complex float temp;
int i,info,ix,j,jy,kx;
// Test the input parameters.
int i, info, ix, j, jy, kx;
// Test the input parameters.
info = 0;
if (m < 0) {
info = 1;
@ -160,51 +159,45 @@ void cgerc(int m, int n, complex float alpha, complex float x[], int incx,
info = 5;
} else if (incy == 0) {
info = 7;
} else if (lda < max(1,m)) {
} else if (lda < fmax(1, m)) {
info = 9;
}
if (info != 0) {
xerbla('CGERC ',info);
xerbla("CGERC ",info);
return;
}
// Quick return if possible.
if ((m == 0) || (n == 0) || (alpha == zero)) return;
// Start the operations. In this version the elements of A are
// accessed sequentially with one pass through A.
// Quick return if possible.
if (m == 0 || n == 0 || alpha == zero) return;
// Start the operations. In this version the elements of A are accessed sequentially with one pass through A.
if (incy > 0) {
jy = 0;
}
else {
jy = 0 - (n-1)*incy;
} else {
jy = 0 - (n - 1) * incy;
}
if (incx == 1) {
for ( j = 0; j < n; j++ ) {
for (j = 0; j < n; j++) {
if (y[jy] != zero) {
temp = alpha*(~y[jy]);
for ( i = 0; i < m; i++ ) {
a[i+j*lda] = a[i+j*lda] + x[i]*temp;
temp = alpha * conj(y[jy]);
for (i = 0; i < m; i++) {
a[i + j * lda] = a[i + j * lda] + x[i] * temp;
}
}
jy = jy + incy;
}
}
else {
} else {
if (incx > 0) {
kx = 0;
} else {
kx = 0 - (m - 1) * incx;
}
else {
kx = 0 - (m-1)*incx;
}
for ( j = 0; j < n; j++ ) {
for (j = 0; j < n; j++) {
if (y[jy] != zero) {
temp = alpha*(~y[jy]);
temp = alpha * conj(y[jy]);
ix = kx;
for ( i = 0; i < m; i++ ) {
a[i+j*lda] = a[i+j*lda] + x[ix]*temp;
for (i = 0; i < m; i++) {
a[i + j * lda] = a[i + j * lda] + x[ix] * temp;
ix = ix + incx;
}
}
@ -212,8 +205,6 @@ void cgerc(int m, int n, complex float alpha, complex float x[], int incx,
}
}
return;
// End of CGERC
// End of CGERC .
}
}

178
src/cgeru.c → src/single/cgeru.c
View file

@ -1,3 +1,8 @@
#include <math.h>
#include "blas_internal.h"
/*
*> \brief \b CGERU
*
* =========== DOCUMENTATION ===========
@ -126,99 +131,80 @@
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA
INTEGER INCX,INCY,LDA,M,N
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
* .. Local Scalars ..
COMPLEX TEMP
INTEGER I,INFO,IX,J,JY,KX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
*
* Test the input parameters.
*
INFO = 0
IF (M.LT.0) THEN
INFO = 1
ELSE IF (N.LT.0) THEN
INFO = 2
ELSE IF (INCX.EQ.0) THEN
INFO = 5
ELSE IF (INCY.EQ.0) THEN
INFO = 7
ELSE IF (LDA.LT.MAX(1,M)) THEN
INFO = 9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CGERU ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through A.
*
IF (INCY.GT.0) THEN
JY = 1
ELSE
JY = 1 - (N-1)*INCY
END IF
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (Y(JY).NE.ZERO) THEN
TEMP = ALPHA*Y(JY)
DO 10 I = 1,M
A(I,J) = A(I,J) + X(I)*TEMP
10 CONTINUE
END IF
JY = JY + INCY
20 CONTINUE
ELSE
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (M-1)*INCX
END IF
DO 40 J = 1,N
IF (Y(JY).NE.ZERO) THEN
TEMP = ALPHA*Y(JY)
IX = KX
DO 30 I = 1,M
A(I,J) = A(I,J) + X(IX)*TEMP
IX = IX + INCX
30 CONTINUE
END IF
JY = JY + INCY
40 CONTINUE
END IF
*
RETURN
*
* End of CGERU
*
END
*/
#include <complex.h>
void cgeru(int m, int n, complex float alpha, complex float *x, int incx, complex float *y, int incy, complex float *a, int lda) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float zero = CMPLXF(0.0e0, 0.0e0);
complex float temp;
int i, info, ix, j, jy, kx;
// Test the input parameters.
info = 0;
if (m < 0) {
info = 1;
} else if (n < 0) {
info = 2;
} else if (incx == 0) {
info = 5;
} else if (incy == 0) {
info = 7;
} else if (lda < fmax(1, m)) {
info = 9;
}
if (info != 0) {
xerbla("CGERU ", info);
return;
}
// Quick return if possible.
if (m == 0 || n == 0 || alpha == zero) {
return;
}
// Start the operations. In this version the elements of A are accessed sequentially with one pass through A.
if (incy > 0) {
jy = 0;
} else {
jy = 0 - (n - 1) * incy;
}
if (incx == 1) {
for (j = 0; j < n; j++) {
if (y[jy] != zero) {
temp = alpha * y[jy];
for (i = 0; i < m; i++) {
a[i + j * lda] = a[i + j * lda] + x[i] * temp;
}
}
jy = jy + incy;
}
} else {
if (incx > 0) {
kx = 0;
} else {
kx = 0 - (m - 1) * incx;
}
for (j = 0; j < n; j++) {
if (y[jy] != zero) {
temp = alpha * y[jy];
ix = kx;
for (i = 0; i < m; i++) {
a[i + j * lda] = a[i + j * lda] + x[ix] * temp;
ix = ix + incx;
}
}
jy = jy + incy;
}
}
// End of CGERU
}

360
src/chbmv.c → src/single/chbmv.c
View file

@ -1,3 +1,9 @@
#include <math.h>
#include <complex.h>
#include "blas_internal.h"
/*
*> \brief \b CHBMV
*
* =========== DOCUMENTATION ===========
@ -183,195 +189,165 @@
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA,BETA
INTEGER INCX,INCY,K,LDA,N
CHARACTER UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
COMPLEX ONE
PARAMETER (ONE= (1.0E+0,0.0E+0))
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
* .. Local Scalars ..
COMPLEX TEMP1,TEMP2
INTEGER I,INFO,IX,IY,J,JX,JY,KPLUS1,KX,KY,L
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,MAX,MIN,REAL
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (N.LT.0) THEN
INFO = 2
ELSE IF (K.LT.0) THEN
INFO = 3
ELSE IF (LDA.LT. (K+1)) THEN
INFO = 6
ELSE IF (INCX.EQ.0) THEN
INFO = 8
ELSE IF (INCY.EQ.0) THEN
INFO = 11
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CHBMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* Set up the start points in X and Y.
*
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (N-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (N-1)*INCY
END IF
*
* Start the operations. In this version the elements of the array A
* are accessed sequentially with one pass through A.
*
* First form y := beta*y.
*
IF (BETA.NE.ONE) THEN
IF (INCY.EQ.1) THEN
IF (BETA.EQ.ZERO) THEN
DO 10 I = 1,N
Y(I) = ZERO
10 CONTINUE
ELSE
DO 20 I = 1,N
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
ELSE
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30 I = 1,N
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40 I = 1,N
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF (ALPHA.EQ.ZERO) RETURN
IF (LSAME(UPLO,'U')) THEN
*
* Form y when upper triangle of A is stored.
*
KPLUS1 = K + 1
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 60 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
L = KPLUS1 - J
DO 50 I = MAX(1,J-K),J - 1
Y(I) = Y(I) + TEMP1*A(L+I,J)
TEMP2 = TEMP2 + CONJG(A(L+I,J))*X(I)
50 CONTINUE
Y(J) = Y(J) + TEMP1*REAL(A(KPLUS1,J)) + ALPHA*TEMP2
60 CONTINUE
ELSE
JX = KX
JY = KY
DO 80 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
IX = KX
IY = KY
L = KPLUS1 - J
DO 70 I = MAX(1,J-K),J - 1
Y(IY) = Y(IY) + TEMP1*A(L+I,J)
TEMP2 = TEMP2 + CONJG(A(L+I,J))*X(IX)
IX = IX + INCX
IY = IY + INCY
70 CONTINUE
Y(JY) = Y(JY) + TEMP1*REAL(A(KPLUS1,J)) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
IF (J.GT.K) THEN
KX = KX + INCX
KY = KY + INCY
END IF
80 CONTINUE
END IF
ELSE
*
* Form y when lower triangle of A is stored.
*
IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
DO 100 J = 1,N
TEMP1 = ALPHA*X(J)
TEMP2 = ZERO
Y(J) = Y(J) + TEMP1*REAL(A(1,J))
L = 1 - J
DO 90 I = J + 1,MIN(N,J+K)
Y(I) = Y(I) + TEMP1*A(L+I,J)
TEMP2 = TEMP2 + CONJG(A(L+I,J))*X(I)
90 CONTINUE
Y(J) = Y(J) + ALPHA*TEMP2
100 CONTINUE
ELSE
JX = KX
JY = KY
DO 120 J = 1,N
TEMP1 = ALPHA*X(JX)
TEMP2 = ZERO
Y(JY) = Y(JY) + TEMP1*REAL(A(1,J))
L = 1 - J
IX = JX
IY = JY
DO 110 I = J + 1,MIN(N,J+K)
IX = IX + INCX
IY = IY + INCY
Y(IY) = Y(IY) + TEMP1*A(L+I,J)
TEMP2 = TEMP2 + CONJG(A(L+I,J))*X(IX)
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP2
JX = JX + INCX
JY = JY + INCY
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of CHBMV
*
END
*/
void chbmv(char uplo, int n, int k, complex float alpha, complex float *a, int lda, complex float *x, int incx, complex float beta, complex float *y, int incy) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float one = CMPLXF(1.0, 0.0);
complex float zero = CMPLXF(0.0, 0.0);
complex float temp1, temp2;
int i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l;
// Test the input parameters.
info = 0;
if (uplo != 'U' && uplo != 'L') {
info = 1;
} else if (n < 0) {
info = 2;
} else if (k < 0) {
info = 3;
} else if (lda < (k + 1)) {
info = 6;
} else if (incx == 0) {
info = 8;
} else if (incy == 0) {
info = 11;
}
if (info != 0) {
xerbla("CHBMV ", info);
return;
}
// Quick return if possible.
if (n == 0 || (creal(alpha) == 0.0 && cimag(alpha) == 0.0 && creal(beta) == 1.0 && cimag(beta) == 0.0)) {
return;
}
// Set up the start points in X and Y.
if (incx > 0) {
kx = 0;
} else {
kx = 0 - (n - 1) * incx;
}
if (incy > 0) {
ky = 0;
} else {
ky = 0 - (n - 1) * incy;
}
// Start the operations. In this version, the elements of the array A are accessed sequentially with one pass through A.
// First form y := beta*y.
if (creal(beta) != 1.0 || cimag(beta) != 0.0) {
if (incy == 1) {
if (creal(beta) == 0.0 && cimag(beta) == 0.0) {
for (i = 0; i < n; i++) {
y[i] = CMPLXF(0.0, 0.0);
}
} else {
for (i = 0; i < n; i++) {
y[i] = beta * y[i];
}
}
} else {
iy = ky;
if (creal(beta) == 0.0 && cimag(beta) == 0.0) {
for (i = 0; i < n; i++) {
y[iy] = CMPLXF(0.0, 0.0);
iy += incy;
}
} else {
for (i = 0; i < n; i++) {
y[iy] = beta * y[iy];
iy += incy;
}
}
}
}
if (creal(alpha) == 0.0 && cimag(alpha) == 0.0) {
return;
}
if (uplo == 'U') {
// Form y when upper triangle of A is stored.
kplus1 = k + 1;
if (incx == 1 && incy == 1) {
for (j = 0; j < n; j++) {
temp1 = alpha * x[j];
temp2 = CMPLXF(0.0, 0.0);
l = kplus1 - j;
for (i = fmax(0, j - k); i < j; i++) {
y[i] += temp1 * a[l + i + j * lda];
temp2 += conj(a[l + i + j * lda]) * x[i];
}
y[j] += temp1 * a[kplus1 + j * lda] + alpha * temp2;
}
} else {
jx = kx;
jy = ky;
for (j = 0; j < n; j++) {
temp1 = alpha * x[jx];
temp2 = CMPLXF(0.0, 0.0);
ix = kx;
iy = ky;
l = kplus1 - j;
for (i = fmax(0, j - k); i < j; i++) {
y[iy] += temp1 * a[l + i + j * lda];
temp2 += conj(a[l + i + j * lda]) * x[ix];
ix += incx;
iy += incy;
}
y[jy] += temp1 * a[kplus1 + j * lda] + alpha * temp2;
jx += incx;
jy += incy;
if (j > k) {
kx += incx;
ky += incy;
}
}
}
} else {
// Form y when lower triangle of A is stored.
if (incx == 1 && incy == 1) {
for (j = 0; j < n; j++) {
temp1 = alpha * x[j];
temp2 = CMPLXF(0.0, 0.0);
y[j] += temp1 * a[j * lda];
l = 1 - j;
for (i = j + 1; i < fmin(n, j + k); i++) {
y[i] += temp1 * a[l + i + j * lda];
temp2 += conj(a[l + i + j * lda]) * x[i];
}
y[j] += alpha * temp2;
}
} else {
jx = kx;
jy = ky;
for (j = 0; j < n; j++) {
temp1 = alpha * x[jx];
temp2 = CMPLXF(0.0, 0.0);
y[jy] += temp1 * a[j * lda];
l = 1 - j;
ix = jx;
iy = jy;
for (i = j + 1; i < fmin(n, j + k); i++) {
ix += incx;
iy += incy;
y[iy] += temp1 * a[l + i + j * lda];
temp2 += conj(a[l + i + j * lda]) * x[ix];
}
y[jy] += alpha * temp2;
jx += incx;
jy += incy;
}
}
}
// End of CHBMV
}

327
src/chemm.c → src/single/chemm.c
View file

@ -1,3 +1,10 @@
#include <math.h>
#include <complex.h>
#include <stdbool.h>
#include "blas_internal.h"
/*
*> \brief \b CHEMM
*
* =========== DOCUMENTATION ===========
@ -187,182 +194,144 @@
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* -- Reference BLAS level3 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA,BETA
INTEGER LDA,LDB,LDC,M,N
CHARACTER SIDE,UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC CONJG,MAX,REAL
* ..
* .. Local Scalars ..
COMPLEX TEMP1,TEMP2
INTEGER I,INFO,J,K,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
COMPLEX ONE
PARAMETER (ONE= (1.0E+0,0.0E+0))
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
*
* Set NROWA as the number of rows of A.
*
IF (LSAME(SIDE,'L')) THEN
NROWA = M
ELSE
NROWA = N
END IF
UPPER = LSAME(UPLO,'U')
*
* Test the input parameters.
*
INFO = 0
IF ((.NOT.LSAME(SIDE,'L')) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
INFO = 1
ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
INFO = 2
ELSE IF (M.LT.0) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 7
ELSE IF (LDB.LT.MAX(1,M)) THEN
INFO = 9
ELSE IF (LDC.LT.MAX(1,M)) THEN
INFO = 12
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CHEMM ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+ ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* And when alpha.eq.zero.
*
IF (ALPHA.EQ.ZERO) THEN
IF (BETA.EQ.ZERO) THEN
DO 20 J = 1,N
DO 10 I = 1,M
C(I,J) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1,N
DO 30 I = 1,M
C(I,J) = BETA*C(I,J)
30 CONTINUE
40 CONTINUE
END IF
RETURN
END IF
*
* Start the operations.
*
IF (LSAME(SIDE,'L')) THEN
*
* Form C := alpha*A*B + beta*C.
*
IF (UPPER) THEN
DO 70 J = 1,N
DO 60 I = 1,M
TEMP1 = ALPHA*B(I,J)
TEMP2 = ZERO
DO 50 K = 1,I - 1
C(K,J) = C(K,J) + TEMP1*A(K,I)
TEMP2 = TEMP2 + B(K,J)*CONJG(A(K,I))
50 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = TEMP1*REAL(A(I,I)) + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + TEMP1*REAL(A(I,I)) +
+ ALPHA*TEMP2
END IF
60 CONTINUE
70 CONTINUE
ELSE
DO 100 J = 1,N
DO 90 I = M,1,-1
TEMP1 = ALPHA*B(I,J)
TEMP2 = ZERO
DO 80 K = I + 1,M
C(K,J) = C(K,J) + TEMP1*A(K,I)
TEMP2 = TEMP2 + B(K,J)*CONJG(A(K,I))
80 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = TEMP1*REAL(A(I,I)) + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + TEMP1*REAL(A(I,I)) +
+ ALPHA*TEMP2
END IF
90 CONTINUE
100 CONTINUE
END IF
ELSE
*
* Form C := alpha*B*A + beta*C.
*
DO 170 J = 1,N
TEMP1 = ALPHA*REAL(A(J,J))
IF (BETA.EQ.ZERO) THEN
DO 110 I = 1,M
C(I,J) = TEMP1*B(I,J)
110 CONTINUE
ELSE
DO 120 I = 1,M
C(I,J) = BETA*C(I,J) + TEMP1*B(I,J)
120 CONTINUE
END IF
DO 140 K = 1,J - 1
IF (UPPER) THEN
TEMP1 = ALPHA*A(K,J)
ELSE
TEMP1 = ALPHA*CONJG(A(J,K))
END IF
DO 130 I = 1,M
C(I,J) = C(I,J) + TEMP1*B(I,K)
130 CONTINUE
140 CONTINUE
DO 160 K = J + 1,N
IF (UPPER) THEN
TEMP1 = ALPHA*CONJG(A(J,K))
ELSE
TEMP1 = ALPHA*A(K,J)
END IF
DO 150 I = 1,M
C(I,J) = C(I,J) + TEMP1*B(I,K)
150 CONTINUE
160 CONTINUE
170 CONTINUE
END IF
*
RETURN
*
* End of CHEMM
*
END
*/
void chemm(char side, char uplo, int m, int n, complex float alpha, complex float *a, int lda, complex float *b, int ldb, complex float beta, complex float *c, int ldc) {
// -- Reference BLAS level3 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float temp1, temp2;
int i, info, j, k, nrowa;
bool upper;
// Set NROWA as the number of rows of A.
if (side == 'L') {
nrowa = m;
} else {
nrowa = n;
}
upper = (uplo == 'U');
// Test the input parameters.
info = 0;
if ((side != 'L') && (side != 'R')) {
info = 1;
} else if ((!upper) && (uplo != 'L')) {
info = 2;
} else if (m < 0) {
info = 3;
} else if (n < 0) {
info = 4;
} else if (lda < fmax(1, nrowa)) {
info = 7;
} else if (ldb < fmax(1, m)) {
info = 9;
} else if (ldc < fmax(1, m)) {
info = 12;
}
if (info != 0) {
xerbla("CHEMM ", info);
return;
}
// Quick return if possible.
if ((m == 0) || (n == 0) || ((alpha == 0) && (beta == 1))) {
return;
}
// And when alpha = 0.
if (alpha == 0) {
if (beta == 0) {
for (j = 0; j < n; j++) {
for (i = 0; i < m; i++) {
c[i + j * ldc] = 0;
}
}
} else {
for (j = 0; j < n; j++) {
for (i = 0; i < m; i++) {
c[i + j * ldc] = beta * c[i + j * ldc];
}
}
}
return;
}
// Start the operations.
if (side == 'L') {
// Form C := alpha * A * B + beta * C.
if (upper) {
for (j = 0; j < n; j++) {
for (i = 0; i < m; i++) {
temp1 = alpha * b[i + j * ldb];
temp2 = 0;
for (k = 0; k < i; k++) {
c[k + j * ldc] = c[k + j * ldc] + temp1 * a[k + i * lda];
temp2 = temp2 + b[k + j * ldb] * conj(a[k + i * lda]);
}
if (beta == 0) {
c[i + j * ldc] = temp1 * creal(a[i + i * lda]) + alpha * temp2;
} else {
c[i + j * ldc] = beta * c[i + j * ldc] + temp1 * creal(a[i + i * lda]) + alpha * temp2;
}
}
}
} else {
for (j = 0; j < n; j++) {
for (i = m - 1; i >= 0; i--) {
temp1 = alpha * b[i + j * ldb];
temp2 = 0;
for (k = i + 1; k < m; k++) {
c[k + j * ldc] = c[k + j * ldc] + temp1 * a[k + i * lda];
temp2 = temp2 + b[k + j * ldb] * conj(a[k + i * lda]);
}
if (beta == 0) {
c[i + j * ldc] = temp1 * creal(a[i + i * lda]) + alpha * temp2;
} else {
c[i + j * ldc] = beta * c[i + j * ldc] + temp1 * creal(a[i + i * lda]) + alpha * temp2;
}
}
}
}
} else {
// Form C := alpha * B * A + beta * C.
for (j = 0; j < n; j++) {
temp1 = alpha * creal(a[j + j * lda]);
if (beta == 0) {
for (i = 0; i < m; i++) {
c[i + j * ldc] = temp1 * b[i + j * ldb];
}
} else {
for (i = 0; i < m; i++) {
c[i + j * ldc] = beta * c[i + j * ldc] + temp1 * b[i + j * ldb];
}
}
for (k = 0; k < j; k++) {
if (upper) {
temp1 = alpha * a[k + j * lda];
} else {
temp1 = alpha * conj(a[j + k * lda]);
}
for (i = 0; i < m; i++) {
c[i + j * ldc] = c[i + j * ldc] + temp1 * b[i + k * ldb];
}
}
for (k = j + 1; k < n; k++) {
if (upper) {
temp1 = alpha * conj(a[j + k * lda]);
} else {
temp1 = alpha * a[k + j * lda];
}
for (i = 0; i < m; i++) {
c[i + j * ldc] = c[i + j * ldc] + temp1 * b[i + k * ldb];
}
}
}
}
// End of CHEMM
}

302
src/single/chemv.c Normal file
View file

@ -0,0 +1,302 @@
#include <math.h>
#include <complex.h>
#include "blas_internal.h"
/*
*> \brief \b CHEMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA,BETA
* INTEGER INCX,INCY,LDA,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHEMV 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 hermitian matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> 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.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, N )
*> 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 hermitian 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 hermitian matrix and the strictly
*> upper triangular part of A is not referenced.
*> Note that the imaginary parts of the diagonal elements need
*> not be set and are assumed to be zero.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> max( 1, n ).
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is COMPLEX
*> On entry, BETA specifies the scalar beta. When BETA is
*> supplied as zero then Y need not be set on input.
*> \endverbatim
*>
*> \param[in,out] Y
*> \verbatim
*> Y is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCY ) ).
*> Before entry, the incremented array Y must contain the n
*> element vector y. On exit, Y is overwritten by the updated
*> vector y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
*/
void chemv(char uplo, int n, complex float alpha, complex float *a, int lda, complex float *x, int incx, complex float beta, complex float *y, int incy) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float temp1, temp2;
int i, info, ix, iy, j, jx, jy, kx, ky;
// Test the input parameters.
info = 0;
if (uplo != 'U' && uplo != 'L') {
info = 1;
} else if (n < 0) {
info = 2;
} else if (lda < fmax(1, n)) {
info = 5;
} else if (incx == 0) {
info = 7;
} else if (incy == 0) {
info = 10;
}
if (info != 0) {
xerbla("CHEMV ", info);
return;
}
// Quick return if possible.
if (n == 0 || (alpha == 0.0 && beta == 1.0)) {
return;
}
// Set up the start points in x and y.
if (incx > 0) {
kx = 0;
} else {
kx = 0 - (n - 1) * incx;
}
if (incy > 0) {
ky = 0;
} else {
ky = 0 - (n - 1) * incy;
}
// Start the operations. In this version the elements of A are accessed sequentially with one pass through the triangular part of A.
// First form y := beta*y.
if (beta != 1.0) {
if (incy == 1) {
if (beta == 0.0) {
for (i = 0; i < n; i++) {
y[i] = 0.0;
}
} else {
for (i = 0; i < n; i++) {
y[i] = beta * y[i];
}
}
} else {
if (beta == 0.0) {
for (i = 0; i < n; i++) {
y[iy] = 0.0;
iy = iy + incy;
}
} else {
for (i = 0; i < n; i++) {
y[iy] = beta * y[iy];
iy = iy + incy;
}
}
}
}
if (alpha == 0.0) {
return;
}
if (uplo == 'U') {
// Form y when A is stored in upper triangle.
if (incx == 1 && incy == 1) {
for (j = 0; j < n; j++) {
temp1 = alpha * x[j];
temp2 = 0.0;
for (i = 0; i < j; i++) {
y[i] = y[i] + temp1 * a[i * lda + j];
temp2 = temp2 + conjf(a[i * lda + j]) * x[i];
}
y[j] = y[j] + temp1 * crealf(a[j * lda + j]) + alpha * temp2;
}
} else {
jx = kx;
jy = ky;
for (j = 0; j < n; j++) {
temp1 = alpha * x[jx];
temp2 = 0.0;
ix = kx;
iy = ky;
for (i = 0; i < j; i++) {
y[iy] = y[iy] + temp1 * a[i * lda + j];
temp2 = temp2 + conjf(a[i * lda + j]) * x[ix];
ix = ix + incx;
iy = iy + incy;
}
y[jy] = y[jy] + temp1 * crealf(a[j * lda + j]) + alpha * temp2;
jx = jx + incx;
jy = jy + incy;
}
}
} else {
// Form y when A is stored in lower triangle.
if (incx == 1 && incy == 1) {
for (j = 0; j < n; j++) {
temp1 = alpha * x[j];
temp2 = 0.0;
y[j] = y[j] + temp1 * crealf(a[j * lda + j]);
for (i = j + 1; i < n; i++) {
y[i] = y[i] + temp1 * a[i * lda + j];
temp2 = temp2 + conjf(a[i * lda + j]) * x[i];
}
y[j] = y[j] + alpha * temp2;
}
} else {
jx = kx;
jy = ky;
for (j = 0; j < n; j++) {
temp1 = alpha * x[jx];
temp2 = 0.0;
y[jy] = y[jy] + temp1 * crealf(a[j * lda + j]);
ix = jx;
iy = jy;
for (i = j + 1; i < n; i++) {
ix = ix + incx;
iy = iy + incy;
y[iy] = y[iy] + temp1 * a[i * lda + j];
temp2 = temp2 + conjf(a[i * lda + j]) * x[ix];
}
y[jy] = y[jy] + alpha * temp2;
jx = jx + incx;
jy = jy + incy;
}
}
}
}

248
src/single/cher.c Normal file
View file

@ -0,0 +1,248 @@
#include <complex.h>
#include "blas_internal.h"
/*
*> \brief \b CHER
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHER(UPLO,N,ALPHA,X,INCX,A,LDA)
*
* .. Scalar Arguments ..
* REAL ALPHA
* INTEGER INCX,LDA,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHER performs the hermitian rank 1 operation
*>
*> A := alpha*x*x**H + A,
*>
*> where alpha is a real scalar, x is an n element vector and A is an
*> n by n hermitian matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> 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.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is REAL
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, N )
*> 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 hermitian 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 hermitian 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.
*> Note that the imaginary parts of the diagonal elements need
*> not be set, they are assumed to be zero, and on exit they
*> are set to zero.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> max( 1, n ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
*/
void cher(char uplo, int n, float alpha, float *x, int incx, float *a, int lda) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float zero = CMPLXF(0.0e0, 0.0e0);;
complex float temp;
int i, info, ix, j, jx, kx;
// Test the input parameters.
info = 0;
if (uplo != 'U' && uplo != 'L') {
info = 1;
} else if (n < 0) {
info = 2;
} else if (incx == 0) {
info = 5;
} else if (lda < (n > 0 ? 1 : n)) {
info = 7;
}
if (info != 0) {
xerbla("CHER", info);
return;
}
// Quick return if possible.
if (n == 0 || alpha == zero) {
return;
}
// Set the start point in X if the increment is not unity.
if (incx <= 0) {
kx = 1 - (n - 1) * incx;
} else if (incx != 1) {
kx = 1;
}
// Start the operations. In this version the elements of A are accessed sequentially with one pass through the triangular part of A.
if (uplo == 'U') {
// Form A when A is stored in upper triangle.
if (incx == 1) {
for (j = 0; j < n; j++) {
if (x[j] != zero) {
temp = alpha * conjf(x[j]);
for (i = 0; i < j; i++) {
a[i + j * lda] += x[i] * temp;
}
a[j + j * lda] = crealf(a[j + j * lda]) + crealf(x[j] * temp);
} else {
a[j + j * lda] = crealf(a[j + j * lda]);
}
}
} else {
jx = kx;
for (j = 0; j < n; j++) {
if (x[jx] != zero) {
temp = alpha * conjf(x[jx]);
ix = kx;
for (i = 0; i < j; i++) {
a[i + j * lda] += x[ix] * temp;
ix += incx;
}
a[j + j * lda] = crealf(a[j + j * lda]) + crealf(x[jx] * temp);
} else {
a[j + j * lda] = crealf(a[j + j * lda]);
}
jx += incx;
}
}
} else {
// Form A when A is stored in lower triangle.
if (incx == 1) {
for (j = 0; j < n; j++) {
if (x[j] != zero) {
temp = alpha * conjf(x[j]);
a[j + j * lda] = crealf(a[j + j * lda]) + crealf(temp * x[j]);
for (i = j + 1; i < n; i++) {
a[i + j * lda] += x[i] * temp;
}
} else {
a[j + j * lda] = crealf(a[j + j * lda]);
}
}
} else {
jx = kx;
for (j = 0; j < n; j++) {
if (x[jx] != zero) {
temp = alpha * conjf(x[jx]);
a[j + j * lda] = crealf(a[j + j * lda]) + crealf(temp * x[jx]);
ix = jx;
for (i = j + 1; i < n; i++) {
ix += incx;
a[i + j * lda] += x[ix] * temp;
}
} else {
a[j + j * lda] = crealf(a[j + j * lda]);
}
jx += incx;
}
}
}
// End of CHER
}

279
src/single/cher2.c Normal file
View file

@ -0,0 +1,279 @@
#include <math.h>
#include <complex.h>
#include "blas_internal.h"
/*
*> \brief \b CHER2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA
* INTEGER INCX,INCY,LDA,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHER2 performs the hermitian rank 2 operation
*>
*> A := alpha*x*y**H + conjg( alpha )*y*x**H + A,
*>
*> where alpha is a scalar, x and y are n element vectors and A is an n
*> by n hermitian matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> 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.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCY ) ).
*> Before entry, the incremented array Y must contain the n
*> element vector y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, N )
*> 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 hermitian 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 hermitian 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.
*> Note that the imaginary parts of the diagonal elements need
*> not be set, they are assumed to be zero, and on exit they
*> are set to zero.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> max( 1, n ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
*/
void cher2(char uplo, int n, complex float alpha, complex float *x, int incx, complex float *y, int incy, complex float *a, int lda) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float temp1, temp2;
int i, info, ix, iy, j, jx, jy, kx, ky;
// Test the input parameters.
info = 0;
if (uplo != 'U' && uplo != 'L') {
info = 1;
} else if (n < 0) {
info = 2;
} else if (incx == 0) {
info = 5;
} else if (incy == 0) {
info = 7;
} else if (lda < fmax(1, n)) {
info = 9;
}
if (info != 0) {
xerbla("CHER2 ", info);
return;
}
// Quick return if possible.
if (n == 0 || alpha == 0.0) {
return;
}
// Set up the start points in x and y if the increments are not both unity.
if (incx != 1 || incy != 1) {
if (incx > 0) {
kx = 0;
} else {
kx = 1 - (n - 1) * incx;
}
if (incy > 0) {
ky = 0;
} else {
ky = 1 - (n - 1) * incy;
}
jx = kx;
jy = ky;
}
// Start the operations. In this version, the elements of a are accessed sequentially with one pass through the triangular part of a.
if (uplo == 'U') {
// Form a when a is stored in the upper triangle.
if (incx == 1 && incy == 1) {
for (j = 0; j < n; j++) {
if (x[j] != 0.0 || y[j] != 0.0) {
temp1 = alpha * conj(y[j]);
temp2 = conj(alpha * x[j]);
for (i = 0; i < j; i++) {
a[i + j * lda] += x[i] * temp1 + y[i] * temp2;
}
a[j + j * lda] = creal(a[j + j * lda]) + creal(x[j] * temp1 + y[j] * temp2);
} else {
a[j + j * lda] = creal(a[j + j * lda]);
}
}
} else {
for (j = 0; j < n; j++) {
if (x[jx] != 0.0 || y[jy] != 0.0) {
temp1 = alpha * conj(y[jy]);
temp2 = conj(alpha * x[jx]);
ix = kx;
iy = ky;
for (i = 0; i < j; i++) {
a[i + j * lda] += x[ix] * temp1 + y[iy] * temp2;
ix += incx;
iy += incy;
}
a[j + j * lda] = creal(a[j + j * lda]) + creal(x[ix] * temp1 + y[iy] * temp2);
} else {
a[j + j * lda] = creal(a[j + j * lda]);
}
jx += incx;
jy += incy;
}
}
} else {
// Form a when a is stored in the lower triangle.
if (incx == 1 && incy == 1) {
for (j = 0; j < n; j++) {
if (x[j] != 0.0 || y[j] != 0.0) {
temp1 = alpha * conj(y[j]);
temp2 = conj(alpha) * x[j];
a[j + j * lda] = creal(a[j + j * lda]) + creal(x[j] * temp1 + y[j] * temp2);
for (i = j + 1; i < n; i++) {
a[i + j * lda] += x[i] * temp1 + y[i] * temp2;
}
} else {
a[j + j * lda] = creal(a[j + j * lda]);
}
}
} else {
for (j = 0; j < n; j++) {
if (x[jx] != 0.0 || y[jy] != 0.0) {
temp1 = alpha * conj(y[jy]);
temp2 = conj(alpha * x[jx]);
a[j + j * lda] = creal(a[j + j * lda]) + creal(x[ix] * temp1 + y[jy] * temp2);
ix = jx;
iy = jy;
for (i = j + 1; i < n; i++) {
ix += incx;
iy += incy;
a[i + j * lda] += x[ix] * temp1 + y[iy] * temp2;
}
} else {
a[j + j * lda] = creal(a[j + j * lda]);
}
jx += incx;
jy += incy;
}
}
}
}

388
src/single/cher2k.c Normal file
View file

@ -0,0 +1,388 @@
#include <math.h>
#include <complex.h>
#include "blas_internal.h"
/*
*> \brief \b CHER2K
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA
* REAL BETA
* INTEGER K,LDA,LDB,LDC,N
* CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHER2K performs one of the hermitian rank 2k operations
*>
*> C := alpha*A*B**H + conjg( alpha )*B*A**H + beta*C,
*>
*> or
*>
*> C := alpha*A**H*B + conjg( alpha )*B**H*A + beta*C,
*>
*> where alpha and beta are scalars with beta real, C is an n by n
*> hermitian matrix and A and B are n by k matrices in the first case
*> and k by n matrices in the second case.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO 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.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' C := alpha*A*B**H +
*> conjg( alpha )*B*A**H +
*> beta*C.
*>
*> TRANS = 'C' or 'c' C := alpha*A**H*B +
*> conjg( alpha )*B**H*A +
*> beta*C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix C. N must be
*> at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> On entry with TRANS = 'N' or 'n', K specifies the number
*> of columns of the matrices A and B, and on entry with
*> TRANS = 'C' or 'c', K specifies the number of rows of the
*> matrices A and B. K must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, ka ), where ka is
*> k when TRANS = 'N' or 'n', and is n otherwise.
*> 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.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA 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 ).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is COMPLEX array, dimension ( LDB, kb ), where kb is
*> k when TRANS = 'N' or 'n', and is n otherwise.
*> 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.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> On entry, LDB 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 ).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is REAL
*> On entry, BETA specifies the scalar beta.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX array, dimension ( LDC, N )
*> 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 hermitian 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 hermitian 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.
*> Note that the imaginary parts of the diagonal elements need
*> not be set, they are assumed to be zero, and on exit they
*> are set to zero.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> On entry, LDC specifies the first dimension of C as declared
*> in the calling (sub) program. LDC must be at least
*> max( 1, n ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level3
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 3 Blas routine.
*>
*> -- Written on 8-February-1989.
*> Jack Dongarra, Argonne National Laboratory.
*> Iain Duff, AERE Harwell.
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
*> Sven Hammarling, Numerical Algorithms Group Ltd.
*>
*> -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1.
*> Ed Anderson, Cray Research Inc.
*> \endverbatim
*>
* =====================================================================
*/
#include <stdbool.h>
void cher2k(char uplo, char trans, int n, int k, float alpha, float* a, int lda, float* b, int ldb, float beta, float* c, int ldc) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float temp1, temp2;
int i, info, j, l, nrowa;
bool upper;
upper = (uplo == 'U');
nrowa = (trans == 'N') ? n : k;
info = 0;
if (!upper && uplo != 'L') {
info = 1;
} else if (trans != 'N' && trans != 'C') {
info = 2;
} else if (n < 0) {
info = 3;
} else if (k < 0) {
info = 4;
} else if (lda < fmax(1, nrowa)) {
info = 7;
} else if (ldb < fmax(1, nrowa)) {
info = 9;
} else if (ldc < fmax(1, n)) {
info = 12;
}
if (info != 0) {
xerbla("CHER2K ", info);
return;
}
// Quick return if possible.
if (n == 0 || (alpha == 0 && k == 0 && beta == 1)) return;
if (alpha == 0) {
if (upper) {
if (beta == 0) {
for (j = 0; j < n; j++) {
for (i = 0; i <= j; i++) {
c[i + j * ldc] = 0;
}
}
} else {
for (j = 0; j < n; j++) {
for (i = 0; i < j; i++) {
c[i + j * ldc] *= beta;
}
c[j + j * ldc] = beta * c[j + j * ldc];
}
}
} else {
if (beta == 0) {
for (j = 0; j < n; j++) {
for (i = j; i < n; i++) {
c[i + j * ldc] = 0;
}
}
} else {
for (j = 0; j < n; j++) {
c[j + j * ldc] = beta * c[j + j * ldc];
for (i = j + 1; i < n; i++) {
c[i + j * ldc] *= beta;
}
}
}
}
return;
}
if (trans == 'N') {
if (upper) {
for (j = 0; j < n; j++) {
if (beta == 0) {
for (i = 0; i <= j; i++) {
c[i + j * ldc] = 0;
}
} else if (beta != 1) {
for (i = 0; i < j; i++) {
c[i + j * ldc] *= beta;
}
c[j + j * ldc] = beta * c[j + j * ldc];
} else {
c[j + j * ldc] = c[j + j * ldc];
}
for (l = 0; l < k; l++) {
if (a[j + l * lda] != 0 || b[j + l * ldb] != 0) {
temp1 = alpha * conjf(b[j + l * ldb]);
temp2 = conjf(alpha) * a[j + l * lda];
for (i = 0; i < j; i++) {
c[i + j * ldc] += a[i + l * lda] * temp1 + b[i + l * ldb] * temp2;
}
c[j + j * ldc] = creal(c[j + j * ldc]) + creal(a[j + l * lda] * temp1 + b[j + l * ldb] * temp2);
}
}
}
} else {
for (j = 0; j < n; j++) {
if (beta == 0) {
for (i = j; i < n; i++) {
c[i + j * ldc] = 0;
}
} else if (beta != 1) {
for (i = j + 1; i < n; i++) {
c[i + j * ldc] *= beta;
}
c[j + j * ldc] = beta * c[j + j * ldc];
} else {
c[j + j * ldc] = c[j + j * ldc];
}
for (l = 0; l < k; l++) {
if (a[j + l * lda] != 0 || b[j + l * ldb] != 0) {
temp1 = alpha * conjf(b[j + l * ldb]);
temp2 = conjf(alpha) * a[j + l * lda];
for (i = j + 1; i < n; i++) {
c[i + j * ldc] += a[i + l * lda] * temp1 + b[i + l * ldb] * temp2;
}
c[j + j * ldc] = creal(c[j + j * ldc]) + creal(a[j + l * lda] * temp1 + b[j + l * ldb] * temp2);
}
}
}
}
} else {
if (upper) {
for (j = 0; j < n; j++) {
for (i = 0; i <= j; i++) {
temp1 = 0;
temp2 = 0;
for (l = 0; l < k; l++) {
temp1 += conjf(a[l + i * lda]) * b[l + j * ldb];
temp2 += conjf(b[l + i * ldb]) * a[l + j * lda];
}
if (i == j) {
if (beta == 0) {
c[j + j * ldc] = creal(alpha * temp1 + conjf(alpha) * temp2);
} else {
c[j + j * ldc] = beta * creal(c[j + j * ldc]) + creal(alpha * temp1 + conjf(alpha) * temp2);
}
} else {
if (beta == 0) {
c[i + j * ldc] = alpha * temp1 + conjf(alpha) * temp2;
} else {
c[i + j * ldc] = beta * c[i + j * ldc] + alpha * temp1 + conjf(alpha) * temp2;
}
}
}
}
} else {
for (j = 0; j < n; j++) {
for (i = j; i < n; i++) {
temp1 = 0;
temp2 = 0;
for (l = 0; l < k; l++) {
temp1 += conjf(a[l + i * lda]) * b[l + j * ldb];
temp2 += conjf(b[l + i * ldb]) * a[l + j * lda];
}
if (i == j) {
if (beta == 0) {
c[j + j * ldc] = creal(alpha * temp1 + conjf(alpha) * temp2);
} else {
c[j + j * ldc] = beta * creal(c[j + j * ldc]) + creal(alpha * temp1 + conjf(alpha) * temp2);
}
} else {
if (beta == 0) {
c[i + j * ldc] = alpha * temp1 + conjf(alpha) * temp2;
} else {
c[i + j * ldc] = beta * c[i + j * ldc] + alpha * temp1 + conjf(alpha) * temp2;
}
}
}
}
}
}
// End of function CHER2K
}

369
src/single/cherk.c Normal file
View file

@ -0,0 +1,369 @@
#include <math.h>
#include <ctype.h>
#include <complex.h>
#include <stdbool.h>
#include "blas_internal.h"
/*
*> \brief \b CHERK
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
*
* .. Scalar Arguments ..
* REAL ALPHA,BETA
* INTEGER K,LDA,LDC,N
* CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHERK performs one of the hermitian rank k operations
*>
*> C := alpha*A*A**H + beta*C,
*>
*> or
*>
*> C := alpha*A**H*A + beta*C,
*>
*> where alpha and beta are real scalars, C is an n by n hermitian
*> matrix and A is an n by k matrix in the first case and a k by n
*> matrix in the second case.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO 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.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' C := alpha*A*A**H + beta*C.
*>
*> TRANS = 'C' or 'c' C := alpha*A**H*A + beta*C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix C. N must be
*> at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> On entry with TRANS = 'N' or 'n', K specifies the number
*> of columns of the matrix A, and on entry with
*> TRANS = 'C' or 'c', K specifies the number of rows of the
*> matrix A. K must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is REAL
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, ka ), where ka is
*> k when TRANS = 'N' or 'n', and is n otherwise.
*> 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.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA 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 ).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is REAL
*> On entry, BETA specifies the scalar beta.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX array, dimension ( LDC, N )
*> 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 hermitian 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 hermitian 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.
*> Note that the imaginary parts of the diagonal elements need
*> not be set, they are assumed to be zero, and on exit they
*> are set to zero.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> On entry, LDC specifies the first dimension of C as declared
*> in the calling (sub) program. LDC must be at least
*> max( 1, n ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level3
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 3 Blas routine.
*>
*> -- Written on 8-February-1989.
*> Jack Dongarra, Argonne National Laboratory.
*> Iain Duff, AERE Harwell.
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
*> Sven Hammarling, Numerical Algorithms Group Ltd.
*>
*> -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1.
*> Ed Anderson, Cray Research Inc.
*> \endverbatim
*>
* =====================================================================
*/
void cherk(char uplo, char trans, int n, int k, float alpha, complex float *a, int lda, float beta, complex float *c, int ldc) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float temp;
float rtemp;
int i, info, j, l, nrowa;
bool upper;
// Test the input parameters.
if (tolower(trans) == 'n') {
nrowa = n;
} else {
nrowa = k;
}
upper = (tolower(uplo) == 'u');
info = 0;
if ((!upper) && (tolower(uplo) != 'l')) {
info = 1;
} else if (tolower(trans) != 'n' && tolower(trans) != 'c') {
info = 2;
} else if (n < 0) {
info = 3;
} else if (k < 0) {
info = 4;
} else if (lda < fmax(1, nrowa)) {
info = 7;
} else if (ldc < fmax(1, n)) {
info = 10;
}
if (info != 0) {
xerbla("cherk ", info);
return;
}
// Quick return if possible.
if (n == 0 || ((alpha == 0 || k == 0) && beta == 1)) {
return;
}
// And when alpha == 0.
if (alpha == 0) {
if (upper) {
if (beta == 0) {
for (j = 0; j < n; j++) {
for (i = 0; i <= j; i++) {
c[i + j * ldc] = 0;
}
}
} else {
for (j = 0; j < n; j++) {
for (i = 0; i < j; i++) {
c[i + j * ldc] = beta * c[i + j * ldc];
}
c[j + j * ldc] = beta * creal(c[j + j * ldc]);
}
}
} else {
if (beta == 0) {
for (j = 0; j < n; j++) {
for (i = j; i < n; i++) {
c[i + j * ldc] = 0;
}
}
} else {
for (j = 0; j < n; j++) {
c[j + j * ldc] = beta * creal(c[j + j * ldc]);
for (i = j + 1; i < n; i++) {
c[i + j * ldc] = beta * c[i + j * ldc];
}
}
}
}
return;
}
// Start the operations.
if (tolower(trans) == 'n') {
// Form C := alpha*A*A**H + beta*C.
if (upper) {
for (j = 0; j < n; j++) {
if (beta == 0) {
for (i = 0; i <= j; i++) {
c[i + j * ldc] = 0;
}
} else if (beta != 1) {
for (i = 0; i < j; i++) {
c[i + j * ldc] = beta * c[i + j * ldc];
}
c[j + j * ldc] = beta * creal(c[j + j * ldc]);
} else {
c[j + j * ldc] = creal(c[j + j * ldc]);
}
for (l = 0; l < k; l++) {
if (a[j + l * lda] != 0) {
temp = alpha * conjf(a[j + l * lda]);
for (i = 0; i < j; i++) {
c[i + j * ldc] = c[i + j * ldc] + temp * a[i + l * lda];
}
c[j + j * ldc] = creal(c[j + j * ldc]) + creal(temp * a[j + l * lda]);
}
}
}
} else {
for (j = 0; j < n; j++) {
if (beta == 0) {
for (i = j; i < n; i++) {
c[i + j * ldc] = 0;
}
} else if (beta != 1) {
c[j + j * ldc] = beta * creal(c[j + j * ldc]);
for (i = j + 1; i < n; i++) {
c[i + j * ldc] = beta * c[i + j * ldc];
}
} else {
c[j + j * ldc] = creal(c[j + j * ldc]);
}
for (l = 0; l < k; l++) {
if (a[j + l * lda] != 0) {
temp = alpha * conjf(a[j + l * lda]);
c[j + j * ldc] = creal(c[j + j * ldc]) + creal(temp * a[j + l * lda]);
for (i = j + 1; i < n; i++) {
c[i + j * ldc] = c[i + j * ldc] + temp * a[i + l * lda];
}
}
}
}
}
} else {
// Form C := alpha*A**H*A + beta*C.
if (upper) {
for (j = 0; j < n; j++) {
for (i = 0; i < j; i++) {
temp = 0;
for (l = 0; l < k; l++) {
temp = temp + conjf(a[l + i * lda]) * a[l + j * lda];
}
if (beta == 0) {
c[i + j * ldc] = alpha * temp;
} else {
c[i + j * ldc] = alpha * temp + beta * c[i + j * ldc];
}
}
rtemp = 0;
for (l = 0; l < k; l++) {
rtemp = rtemp + creal(conjf(a[l + j * lda]) * a[l + j * lda]);
}
if (beta == 0) {
c[j + j * ldc] = alpha * rtemp;
} else {
c[j + j * ldc] = alpha * rtemp + beta * creal(c[j + j * ldc]);
}
}
} else {
for (j = 0; j < n; j++) {
rtemp = 0;
for (l = 0; l < k; l++) {
rtemp = rtemp + creal(conjf(a[l + j * lda]) * a[l + j * lda]);
}
if (beta == 0) {
c[j + j * ldc] = alpha * rtemp;
} else {
c[j + j * ldc] = alpha * rtemp + beta * creal(c[j + j * ldc]);
}
for (i = j + 1; i < n; i++) {
temp = 0;
for (l = 0; l < k; l++) {
temp = temp + conjf(a[l + i * lda]) * a[l + j * lda];
}
if (beta == 0) {
c[i + j * ldc] = alpha * temp;
} else {
c[i + j * ldc] = alpha * temp + beta * c[i + j * ldc];
}
}
}
}
}
// End of CHERK
}

307
src/single/chpmv.c Normal file
View file

@ -0,0 +1,307 @@
#include <complex.h>
#include "blas_internal.h"
/*
*> \brief \b CHPMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA,BETA
* INTEGER INCX,INCY,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX AP(*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHPMV 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 hermitian matrix, supplied in packed form.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the matrix A is supplied in the packed
*> array AP as follows:
*>
*> UPLO = 'U' or 'u' The upper triangular part of A is
*> supplied in AP.
*>
*> UPLO = 'L' or 'l' The lower triangular part of A is
*> supplied in AP.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is COMPLEX array, dimension at least
*> ( ( n*( n + 1 ) )/2 ).
*> Before entry with UPLO = 'U' or 'u', the array AP must
*> contain the upper triangular part of the hermitian matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
*> and a( 2, 2 ) respectively, and so on.
*> Before entry with UPLO = 'L' or 'l', the array AP must
*> contain the lower triangular part of the hermitian matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
*> and a( 3, 1 ) respectively, and so on.
*> Note that the imaginary parts of the diagonal elements need
*> not be set and are assumed to be zero.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is COMPLEX
*> On entry, BETA specifies the scalar beta. When BETA is
*> supplied as zero then Y need not be set on input.
*> \endverbatim
*>
*> \param[in,out] Y
*> \verbatim
*> Y is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCY ) ).
*> Before entry, the incremented array Y must contain the n
*> element vector y. On exit, Y is overwritten by the updated
*> vector y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
*/
void chpmv(char uplo, int n, complex float alpha, complex float *ap, complex float *x, int incx, complex float beta, complex float *y, int incy) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float temp1, temp2;
int i, info, ix, iy, j, jx, jy, k, kk, kx, ky;
// Test the input parameters.
info = 0;
if (uplo != 'U' && uplo != 'L') {
info = 1;
} else if (n < 0) {
info = 2;
} else if (incx == 0) {
info = 6;
} else if (incy == 0) {
info = 9;
}
if (info != 0) {
xerbla("CHPMV ", info);
return;
}
// Quick return if possible.
if (n == 0 || (alpha == 0.0 && beta == 1.0)) {
return;
}
// Set up the start points in X and Y.
if (incx > 0) {
kx = 0;
} else {
kx = 0 - (n - 1) * incx;
}
if (incy > 0) {
ky = 0;
} else {
ky = 0 - (n - 1) * incy;
}
// Start the operations. In this version the elements of the array AP are accessed sequentially with one pass through AP.
// First form y := beta*y.
if (beta != 1.0) {
if (incy == 1) {
if (beta == 0.0) {
for (i = 0; i < n; i++) {
y[i] = 0.0;
}
} else {
for (i = 0; i < n; i++) {
y[i] = beta * y[i];
}
}
} else {
iy = ky;
if (beta == 0.0) {
for (i = 0; i < n; i++) {
y[iy] = 0.0;
iy = iy + incy;
}
} else {
for (i = 0; i < n; i++) {
y[iy] = beta * y[iy];
iy = iy + incy;
}
}
}
}
if (alpha == 0.0) {
return;
}
kk = 0;
if (uplo == 'U') {
// Form y when AP contains the upper triangle.
if (incx == 1 && incy == 1) {
for (j = 0; j < n; j++) {
temp1 = alpha * x[j];
temp2 = 0.0;
k = kk;
for (i = 0; i < j; i++) {
y[i] = y[i] + temp1 * ap[k];
temp2 = temp2 + conj(ap[k]) * x[i];
k = k + 1;
}
y[j] = y[j] + temp1 * creal(ap[kk + j]) + alpha * temp2;
kk = kk + j;
}
} else {
jx = kx;
jy = ky;
for (j = 0; j < n; j++) {
temp1 = alpha * x[jx];
temp2 = 0.0;
ix = kx;
iy = ky;
for (k = kk; k < kk + j - 1; k++) {
y[iy] = y[iy] + temp1 * ap[k];
temp2 = temp2 + conj(ap[k]) * x[ix];
ix = ix + incx;
iy = iy + incy;
}
y[jy] = y[jy] + temp1 * creal(ap[kk + j - 1]) + alpha * temp2;
jx = jx + incx;
jy = jy + incy;
kk = kk + j;
}
}
} else {
// Form y when AP contains the lower triangle.
if (incx == 1 && incy == 1) {
for (j = 0; j < n; j++) {
temp1 = alpha * x[j];
temp2 = 0.0;
y[j] = y[j] + temp1 * creal(ap[kk]);
k = kk + 1;
for (i = j + 1; i < n; i++) {
y[i] = y[i] + temp1 * ap[k];
temp2 = temp2 + conj(ap[k]) * x[i];
k = k + 1;
}
y[j] = y[j] + alpha * temp2;
kk = kk + (n - j + 1);
}
} else {
jx = kx;
jy = ky;
for (j = 0; j < n; j++) {
temp1 = alpha * x[jx];
temp2 = 0.0;
y[jy] = y[jy] + temp1 * creal(ap[kk]);
ix = jx;
iy = jy;
for (k = kk + 1; k < kk + n - j; k++) {
ix = ix + incx;
iy = iy + incy;
y[iy] = y[iy] + temp1 * ap[k];
temp2 = temp2 + conj(ap[k]) * x[ix];
}
y[jy] = y[jy] + alpha * temp2;
jx = jx + incx;
jy = jy + incy;
kk = kk + (n - j + 1);
}
}
}
// End of CHPMV
}

250
src/single/chpr.c Normal file
View file

@ -0,0 +1,250 @@
#include <complex.h>
#include "blas_internal.h"
/*
*> \brief \b CHPR
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHPR(UPLO,N,ALPHA,X,INCX,AP)
*
* .. Scalar Arguments ..
* REAL ALPHA
* INTEGER INCX,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX AP(*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHPR performs the hermitian rank 1 operation
*>
*> A := alpha*x*x**H + A,
*>
*> where alpha is a real scalar, x is an n element vector and A is an
*> n by n hermitian matrix, supplied in packed form.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the matrix A is supplied in the packed
*> array AP as follows:
*>
*> UPLO = 'U' or 'u' The upper triangular part of A is
*> supplied in AP.
*>
*> UPLO = 'L' or 'l' The lower triangular part of A is
*> supplied in AP.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is REAL
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in,out] AP
*> \verbatim
*> AP is COMPLEX array, dimension at least
*> ( ( n*( n + 1 ) )/2 ).
*> Before entry with UPLO = 'U' or 'u', the array AP must
*> contain the upper triangular part of the hermitian matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
*> and a( 2, 2 ) respectively, and so on. On exit, the array
*> AP is overwritten by the upper triangular part of the
*> updated matrix.
*> Before entry with UPLO = 'L' or 'l', the array AP must
*> contain the lower triangular part of the hermitian matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
*> and a( 3, 1 ) respectively, and so on. On exit, the array
*> AP is overwritten by the lower triangular part of the
*> updated matrix.
*> Note that the imaginary parts of the diagonal elements need
*> not be set, they are assumed to be zero, and on exit they
*> are set to zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
*/
void chpr(char uplo, int n, float alpha, complex float *x, int incx, complex float *ap) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float temp;
int i, info, ix, j, jx, k, kk, kx;
// Test the input parameters.
info = 0;
if (uplo != 'U' && uplo != 'L') {
info = 1;
} else if (n < 0) {
info = 2;
} else if (incx == 0) {
info = 5;
}
if (info != 0) {
xerbla("CHPR ", info);
return;
}
// Quick return if possible.
if (n == 0 || alpha == 0.0f) {
return;
}
// Set the start point in x if the increment is not unity.
if (incx <= 0) {
kx = 1 - (n - 1) * incx;
} else if (incx != 1) {
kx = 1;
}
// Start the operations. In this version the elements of the array ap
// are accessed sequentially with one pass through ap.
kk = 1;
if (uplo == 'U') {
// Form A when upper triangle is stored in ap.
if (incx == 1) {
for (j = 1; j <= n; j++) {
if (x[j] != 0.0f) {
temp = alpha * conjf(x[j]);
k = kk;
for (i = 1; i <= j - 1; i++) {
ap[k] = ap[k] + x[i] * temp;
k = k + 1;
}
ap[kk + j - 1] = crealf(ap[kk + j - 1]) + crealf(x[j] * temp);
} else {
ap[kk + j - 1] = crealf(ap[kk + j - 1]);
}
kk = kk + j;
}
} else {
jx = kx;
for (j = 1; j <= n; j++) {
if (x[jx] != 0.0f) {
temp = alpha * conjf(x[jx]);
ix = kx;
for (k = kk; k <= kk + j - 2; k++) {
ap[k] = ap[k] + x[ix] * temp;
ix = ix + incx;
}
ap[kk + j - 1] = crealf(ap[kk + j - 1]) + crealf(x[jx] * temp);
} else {
ap[kk + j - 1] = crealf(ap[kk + j - 1]);
}
jx = jx + incx;
kk = kk + j;
}
}
} else {
// Form A when lower triangle is stored in ap.
if (incx == 1) {
for (j = 1; j <= n; j++) {
if (x[j] != 0.0f) {
temp = alpha * conjf(x[j]);
ap[kk] = crealf(ap[kk]) + crealf(temp * x[j]);
k = kk + 1;
for (i = j + 1; i <= n; i++) {
ap[k] = ap[k] + x[i] * temp;
k = k + 1;
}
} else {
ap[kk] = crealf(ap[kk]);
}
kk = kk + n - j + 1;
}
} else {
jx = kx;
for (j = 1; j <= n; j++) {
if (x[jx] != 0.0f) {
temp = alpha * conjf(x[jx]);
ap[kk] = crealf(ap[kk]) + crealf(temp * x[jx]);
ix = jx;
for (k = kk + 1; k <= kk + n - j; k++) {
ix = ix + incx;
ap[k] = ap[k] + x[ix] * temp;
}
} else {
ap[kk] = crealf(ap[kk]);
}
jx = jx + incx;
kk = kk + n - j + 1;
}
}
}
// End of CHPR
}

283
src/single/chpr2.c Normal file
View file

@ -0,0 +1,283 @@
#include <complex.h>
#include "blas_internal.h"
/*
*> \brief \b CHPR2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA
* INTEGER INCX,INCY,N
* CHARACTER UPLO
* ..
* .. Array Arguments ..
* COMPLEX AP(*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CHPR2 performs the hermitian rank 2 operation
*>
*> A := alpha*x*y**H + conjg( alpha )*y*x**H + A,
*>
*> where alpha is a scalar, x and y are n element vectors and A is an
*> n by n hermitian matrix, supplied in packed form.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the upper or lower
*> triangular part of the matrix A is supplied in the packed
*> array AP as follows:
*>
*> UPLO = 'U' or 'u' The upper triangular part of A is
*> supplied in AP.
*>
*> UPLO = 'L' or 'l' The lower triangular part of A is
*> supplied in AP.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is COMPLEX array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCY ) ).
*> Before entry, the incremented array Y must contain the n
*> element vector y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> \endverbatim
*>
*> \param[in,out] AP
*> \verbatim
*> AP is COMPLEX array, dimension at least
*> ( ( n*( n + 1 ) )/2 ).
*> Before entry with UPLO = 'U' or 'u', the array AP must
*> contain the upper triangular part of the hermitian matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
*> and a( 2, 2 ) respectively, and so on. On exit, the array
*> AP is overwritten by the upper triangular part of the
*> updated matrix.
*> Before entry with UPLO = 'L' or 'l', the array AP must
*> contain the lower triangular part of the hermitian matrix
*> packed sequentially, column by column, so that AP( 1 )
*> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
*> and a( 3, 1 ) respectively, and so on. On exit, the array
*> AP is overwritten by the lower triangular part of the
*> updated matrix.
*> Note that the imaginary parts of the diagonal elements need
*> not be set, they are assumed to be zero, and on exit they
*> are set to zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
*/
void chpr2(char uplo, int n, complex float alpha, complex float *x, int incx, complex float *y, int incy, complex float *ap) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float temp1, temp2;
int i, info, ix, iy, j, jx, jy, k, kk, kx, ky;
// Test the input parameters.
info = 0;
if (uplo != 'U' && uplo != 'L') {
info = 1;
} else if (n < 0) {
info = 2;
} else if (incx == 0) {
info = 5;
} else if (incy == 0) {
info = 7;
}
if (info != 0) {
xerbla("CHPR2 ", info);
return;
}
// Quick return if possible.
if (n == 0 || alpha == 0.0) {
return;
}
// Set up the start points in x and y if the increments are not both unity.
if (incx != 1 || incy != 1) {
if (incx > 0) {
kx = 0;
} else {
kx = 1 - (n - 1) * incx;
}
if (incy > 0) {
ky = 0;
} else {
ky = 1 - (n - 1) * incy;
}
jx = kx;
jy = ky;
}
// Start the operations. In this version the elements of the array ap are accessed sequentially with one pass through ap.
kk = 0;
if (uplo == 'U') {
// Form A when upper triangle is stored in ap.
if (incx == 1 && incy == 1) {
for (j = 0; j < n; j++) {
if (x[j] != 0.0 || y[j] != 0.0) {
temp1 = alpha * conj(y[j]);
temp2 = conj(alpha) * x[j];
k = kk;
for (i = 0; i < j; i++) {
ap[k] += x[i] * temp1 + y[i] * temp2;
k++;
}
ap[kk + j] = creal(ap[kk + j]) + creal(x[j] * temp1 + y[j] * temp2);
} else {
ap[kk + j] = creal(ap[kk + j]);
}
kk += j;
}
} else {
for (j = 0; j < n; j++) {
if (x[jx] != 0.0 || y[jy] != 0.0) {
temp1 = alpha * conj(y[jy]);
temp2 = conj(alpha) * x[jx];
ix = kx;
iy = ky;
for (k = kk; k < kk + j - 1; k++) {
ap[k] += x[ix] * temp1 + y[iy] * temp2;
ix += incx;
iy += incy;
}
ap[kk + j] = creal(ap[kk + j]) + creal(x[jx] * temp1 + y[jy] * temp2);
} else {
ap[kk + j] = creal(ap[kk + j]);
}
jx += incx;
jy += incy;
kk += j;
}
}
} else {
// Form A when lower triangle is stored in ap.
if (incx == 1 && incy == 1) {
for (j = 0; j < n; j++) {
if (x[j] != 0.0 || y[j] != 0.0) {
temp1 = alpha * conj(y[j]);
temp2 = conj(alpha) * x[j];
ap[kk] = creal(ap[kk]) + creal(x[j] * temp1 + y[j] * temp2);
k = kk + 1;
for (i = j + 1; i < n; i++) {
ap[k] += x[i] * temp1 + y[i] * temp2;
k++;
}
} else {
ap[kk] = creal(ap[kk]);
}
kk += n - j + 1;
}
} else {
for (j = 0; j < n; j++) {
if (x[jx] != 0.0 || y[jy] != 0.0) {
temp1 = alpha * conj(y[jy]);
temp2 = conj(alpha) * x[jx];
ap[kk] = creal(ap[kk]) + creal(x[jx] * temp1 + y[jy] * temp2);
ix = jx;
iy = jy;
for (k = kk + 1; k < kk + n - j; k++) {
ix += incx;
iy += incy;
ap[k] += x[ix] * temp1 + y[iy] * temp2;
}
} else {
ap[kk] = creal(ap[kk]);
}
jx += incx;
jy += incy;
kk += n - j + 1;
}
}
}
// End of CHPR2
}

232
src/single/crotg.c Normal file
View file

@ -0,0 +1,232 @@
#include <math.h>
#include <complex.h>
#include <limits.h>
#include "blas_internal.h"
/*
!> \brief \b CROTG generates a Givens rotation with real cosine and complex sine.
!
! =========== DOCUMENTATION ===========
!
! Online html documentation available at
! http://www.netlib.org/lapack/explore-html/
!
!> \par Purpose:
! =============
!>
!> \verbatim
!>
!> CROTG constructs a plane rotation
!> [ c s ] [ a ] = [ r ]
!> [ -conjg(s) c ] [ b ] [ 0 ]
!> where c is real, s is complex, and c**2 + conjg(s)*s = 1.
!>
!> The computation uses the formulas
!> |x| = sqrt( Re(x)**2 + Im(x)**2 )
!> sgn(x) = x / |x| if x /= 0
!> = 1 if x = 0
!> c = |a| / sqrt(|a|**2 + |b|**2)
!> s = sgn(a) * conjg(b) / sqrt(|a|**2 + |b|**2)
!> r = sgn(a)*sqrt(|a|**2 + |b|**2)
!> When a and b are real and r /= 0, the formulas simplify to
!> c = a / r
!> s = b / r
!> the same as in SROTG when |a| > |b|. When |b| >= |a|, the
!> sign of c and s will be different from those computed by SROTG
!> if the signs of a and b are not the same.
!>
!> \endverbatim
!>
!> @see lartg, @see lartgp
!
! Arguments:
! ==========
!
!> \param[in,out] A
!> \verbatim
!> A is COMPLEX
!> On entry, the scalar a.
!> On exit, the scalar r.
!> \endverbatim
!>
!> \param[in] B
!> \verbatim
!> B is COMPLEX
!> The scalar b.
!> \endverbatim
!>
!> \param[out] C
!> \verbatim
!> C is REAL
!> The scalar c.
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!> S is COMPLEX
!> The scalar s.
!> \endverbatim
!
! Authors:
! ========
!
!> \author Weslley Pereira, University of Colorado Denver, USA
!
!> \date December 2021
!
!> \ingroup rotg
!
!> \par Further Details:
! =====================
!>
!> \verbatim
!>
!> Based on the algorithm from
!>
!> Anderson E. (2017)
!> Algorithm 978: Safe Scaling in the Level 1 BLAS
!> ACM Trans Math Softw 44:1--28
!> https://doi.org/10.1145/3061665
!>
!> \endverbatim
!
! =====================================================================
*/
void crotg(complex float *a, complex float *b, float *c, complex float *s) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// Constants
float zero = 0.0f;
float one = 1.0f;
complex float czero = 0.0f;
// Scaling constants
float safmin = powf(2, fmax(__FLT_MIN_EXP__ - 1, 1 - __FLT_MAX_EXP__));
float safmax = powf(2, fmax(1 - __FLT_MIN_EXP__, __FLT_MAX_EXP__ - 1));
float rtmin = sqrtf(safmin);
// Local variables
float d, f1, f2, g1, g2, h2, u, v, w, rtmax;
complex float f, fs, g, gs, r;
// Executable statements
f = *a;
g = *b;
if (g == czero) {
*c = one;
*s = czero;
r = f;
} else if (f == czero) {
*c = zero;
if (creal(g) == zero) {
r = fabs(cimag(g));
*s = conj(g) / r;
} else if (cimag(g) == zero) {
r = fabs(creal(g));
*s = conj(g) / r;
} else {
g1 = fmax(fabs(creal(g)), fabs(cimag(g)));
rtmax = sqrtf(safmax / 2);
if (g1 > rtmin && g1 < rtmax) {
g2 = abssq(g);
d = sqrtf(g2);
*s = conj(g) / d;
r = d;
} else {
// Use scaled algorithm
u = fmin(safmax, fmax(safmin, g1));
gs = g / u;
g2 = abssq(gs);
d = sqrtf(g2);
*s = conj(gs) / d;
r = d * u;
}
}
} else {
f1 = fmax(fabs(creal(f)), fabs(cimag(f)));
g1 = fmax(fabs(creal(g)), fabs(cimag(g)));
rtmax = sqrtf(safmax / 4);
if (f1 > rtmin && f1 < rtmax && g1 > rtmin && g1 < rtmax) {
// Use unscaled algorithm
f2 = abssq(f);
g2 = abssq(g);
h2 = f2 + g2;
if (f2 >= h2 * safmin) {
*c = sqrtf(f2 / h2);
r = f / *c;
rtmax = rtmax * 2;
if (f2 > rtmin && h2 < rtmax) {
*s = conj(g) * (f / sqrtf(f2 * h2));
} else {
*s = conj(g) * (r / h2);
}
} else {
// f2/h2 <= safmin may be subnormal, and h2/f2 may overflow.
// Moreover,
// safmin <= f2*f2 * safmax < f2 * h2 < h2*h2 * safmin <= safmax,
// sqrt(safmin) <= sqrt(f2 * h2) <= sqrt(safmax).
// Also,
// g2 >> f2, which means that h2 = g2.
d = sqrtf(f2 * h2);
*c = f2 / d;
if (*c >= safmin) {
r = f / *c;
} else {
r = f * (h2 / d);
}
*s = conj(g) * (f / d);
}
} else {
u = fmin(safmax, fmax(fmax(safmin, f1), g1));
gs = g / u;
g2 = abssq(gs);
if (f1 / u < rtmin) {
v = fmin(safmax, fmax(safmin, f1));
w = v / u;
fs = f / v;
f2 = abssq(fs);
h2 = f2 * w * w + g2;
} else {
w = one;
fs = f / u;
f2 = abssq(fs);
h2 = f2 + g2;
}
if (f2 >= h2 * safmin) {
*c = sqrtf(f2 / h2);
r = fs / *c;
rtmax = rtmax * 2;
if (f2 > rtmin && h2 < rtmax) {
*s = conj(gs) * (fs / sqrtf(f2 * h2));
} else {
*s = conj(gs) * (r / h2);
}
} else {
// f2/h2 <= safmin may be subnormal, and h2/f2 may overflow.
// Moreover,
// safmin <= f2*f2 * safmax < f2 * h2 < h2*h2 * safmin <= safmax,
// sqrt(safmin) <= sqrt(f2 * h2) <= sqrt(safmax).
// Also,
// g2 >> f2, which means that h2 = g2.
d = sqrtf(f2 * h2);
*c = f2 / d;
if (*c >= safmin) {
r = fs / *c;
} else {
r = fs * (h2 / d);
}
*s = conj(gs) * (fs / d);
}
*c = *c * w;
r = r * u;
}
}
*a = r;
}

31
src/cscal.c → src/single/cscal.c
View file

@ -1,7 +1,5 @@
#include <complex.h>
#include "blas.h"
/*
*> \brief \b CSCAL
*
@ -80,40 +78,39 @@
*>
* =====================================================================
*/
void cscal(int n, float complex ca, float complex *cx, int incx) {
void cscal(int n, complex float ca, complex float *cx, int incx) {
// -- Reference BLAS level1 routine (version 3.4.0) --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// November 2011
//
// =====================================================================
// .. Local Scalars ..
int i;
int i, nincx;
complex float one;
one = CMPLXF(1.0e0, 0.0e0);
if ( n <= 0 || incx <= 0 ) {
if (n <= 0 || incx <= 0 || (creal(ca) == creal(one) && cimag(ca) == cimag(one))) {
return;
}
if (incx == 1) {
//
// code for increment equal to 1
//
// code for increment equal to 1
for (i = 0; i < n; i++) {
cx[i] = ca * cx[i];
}
} else {
//
// code for increment not equal to 1
//
for (i = 0; i < n; i++) {
cx[i*incx] = ca * cx[i*incx];
// code for increment not equal to 1
nincx = n * incx;
for (i = 0; i < nincx; i += incx) {
cx[i] = ca * cx[i];
}
}
return;
// End of CSCAL
}

68
src/csrot.c → src/single/csrot.c
View file

@ -1,7 +1,5 @@
#include <complex.h>
#include "blas.h"
/*
*> \brief \b CSROT
*
@ -100,8 +98,7 @@
*
* =====================================================================
*/
void csrot ( int n, float complex cx[], int incx, float complex cy[],
int incy, float c, float s ) {
void csrot(int n, complex float *cx, int incx, complex float *cy, int incy, float c, float s) {
// -- Reference BLAS level1 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
@ -110,49 +107,34 @@ void csrot ( int n, float complex cx[], int incx, float complex cy[],
// =====================================================================
// .. Local Scalars ..
float complex ctemp;
int i, ix, iy;
int i, ix, iy;
complex float ctemp;
if ( n <= 0 ) {
return;
}
if (n <= 0) return;
if ( incx == 1 && incy == 1 ) {
// code for both increments equal to 1
for ( i = 0; i < n; i++ ) {
ctemp = c * cx[i] + s * cy[i];
cy[i] = c * cy[i] - s * cx[i];
cx[i] = ctemp;
}
} else {
// code for unequal increments or equal increments not equal
// to 1
if ( 0 <= incx ) {
if (incx == 1 && incy == 1) {
// code for both increments equal to 1
for (i = 0; i < n; i++) {
ctemp = c * cx[i] + s * cy[i];
cy[i] = c * cy[i] - s * cx[i];
cx[i] = ctemp;
}
} else {
// code for unequal increments or equal increments not equal to 1
ix = 0;
} else {
ix = ( -n + 1 ) * incx;
}
if ( 0 <= incy ) {
iy = 0;
} else {
iy = ( -n + 1 ) * incy;
}
for ( i = 0; i < n; i++ ) {
ctemp = c * cx[ix] + s * cy[iy];
cy[iy] = c * cy[iy] - s * cx[ix];
cx[ix] = ctemp;
ix = ix + incx;
iy = iy + incy;
}
}
return;
if (incx < 0)
ix = (-n + 1) * incx;
if (incy < 0)
iy = (-n + 1) * incy;
for (i = 0; i < n; i++) {
ctemp = c * cx[ix] + s * cy[iy];
cy[iy] = c * cy[iy] - s * cx[ix];
cx[ix] = ctemp;
ix += incx;
iy += incy;
}
}
// End of CSROT

40
src/csscal.c → src/single/csscal.c
View file

@ -1,7 +1,5 @@
#include <complex.h>
#include "blas.h"
/*
*> \brief \b CSSCAL
*
@ -80,7 +78,7 @@
*>
* =====================================================================
*/
void csscal ( int n, float sa, float complex cx[], int incx ) {
void csscal(int n, float sa, complex float *cx, int incx) {
// -- Reference BLAS level1 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
@ -89,29 +87,23 @@ void csscal ( int n, float sa, float complex cx[], int incx ) {
// =====================================================================
// .. Local Scalars ..
int i;
int i, nincx;
float one = 1.0;
if ( n <= 0 || incx <= 0 ) {
return;
}
if (n <= 0 || incx <= 0 || sa == one) return;
if ( incx == 1 ) {
// code for increment equal to 1
for ( i = 0; i < n; i++ ) {
cx[i] = sa * cx[i];
}
} else {
// code for increment not equal to 1
for ( i = 0; i < n; i++ ) {
cx[i*incx] = sa * cx[i*incx];
}
}
return;
if (incx == 1) {
// code for increment equal to 1
for (i = 0; i < n; i++) {
cx[i] = sa * creal(cx[i]) + sa * cimag(cx[i]) * I;
}
} else {
// code for increment not equal to 1
nincx = n * incx;
for (i = 0; i < nincx; i += incx) {
cx[i] = sa * creal(cx[i]) + sa * cimag(cx[i]) * I;
}
}
// End of CSSCAL

63
src/cswap.c → src/single/cswap.c
View file

@ -1,7 +1,5 @@
#include <complex.h>
#include "blas.h"
/*
*> \brief \b CSWAP
*
@ -83,54 +81,37 @@
*>
* =====================================================================
*/
void cswap ( int n, float complex cx[], int incx, float complex cy[],
int incy ) {
void cswap(int n, complex float *cx, int incx, complex float *cy, int incy) {
// -- Reference BLAS level1 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
float complex ctemp;
int i, ix, iy;
if ( n <= 0 ) return;
if ( incx == 1 && incy == 1 ) {
// code for both increments equal to 1
for ( i = 0; i < n; i++ ) {
ctemp = cx[i];
cx[i] = cy[i];
cy[i] = ctemp;
}
} else {
// code for unequal increments or equal increments not equal
// to 1
if ( 0 <= incx ) {
complex float ctemp;
int i, ix, iy;
if (n <= 0) return;
if (incx == 1 && incy == 1) {
for (i = 0; i < n; i++) {
ctemp = cx[i];
cx[i] = cy[i];
cy[i] = ctemp;
}
} else {
ix = 0;
} else {
ix = ( -n + 1 ) * incx;
}
if ( 0 <= incy ) {
iy = 0;
} else {
iy = ( -n + 1 ) * incy;
}
for ( i = 0; i < n; i++ ) {
ctemp = cx[ix];
cx[ix] = cy[iy];
cy[iy] = ctemp;
ix = ix + incx;
iy = iy + incy;
}
}
return;
if (incx < 0) ix = (-n + 1) * incx;
if (incy < 0) iy = (-n + 1) * incy;
for (i = 0; i < n; i++) {
ctemp = cx[ix];
cx[ix] = cy[iy];
cy[iy] = ctemp;
ix += incx;
iy += incy;
}
}
// End of CSWAP

321
src/csymm.c → src/single/csymm.c
View file

@ -1,3 +1,10 @@
#include <math.h>
#include <complex.h>
#include <stdbool.h>
#include "blas_internal.h"
/*
*> \brief \b CSYMM
*
* =========== DOCUMENTATION ===========
@ -185,182 +192,138 @@
*> \endverbatim
*>
* =====================================================================
SUBROUTINE CSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* -- Reference BLAS level3 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
COMPLEX ALPHA,BETA
INTEGER LDA,LDB,LDC,M,N
CHARACTER SIDE,UPLO
* ..
* .. Array Arguments ..
COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Local Scalars ..
COMPLEX TEMP1,TEMP2
INTEGER I,INFO,J,K,NROWA
LOGICAL UPPER
* ..
* .. Parameters ..
COMPLEX ONE
PARAMETER (ONE= (1.0E+0,0.0E+0))
COMPLEX ZERO
PARAMETER (ZERO= (0.0E+0,0.0E+0))
* ..
*
* Set NROWA as the number of rows of A.
*
IF (LSAME(SIDE,'L')) THEN
NROWA = M
ELSE
NROWA = N
END IF
UPPER = LSAME(UPLO,'U')
*
* Test the input parameters.
*
INFO = 0
IF ((.NOT.LSAME(SIDE,'L')) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
INFO = 1
ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
INFO = 2
ELSE IF (M.LT.0) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 7
ELSE IF (LDB.LT.MAX(1,M)) THEN
INFO = 9
ELSE IF (LDC.LT.MAX(1,M)) THEN
INFO = 12
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('CSYMM ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+ ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* And when alpha.eq.zero.
*
IF (ALPHA.EQ.ZERO) THEN
IF (BETA.EQ.ZERO) THEN
DO 20 J = 1,N
DO 10 I = 1,M
C(I,J) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1,N
DO 30 I = 1,M
C(I,J) = BETA*C(I,J)
30 CONTINUE
40 CONTINUE
END IF
RETURN
END IF
*
* Start the operations.
*
IF (LSAME(SIDE,'L')) THEN
*
* Form C := alpha*A*B + beta*C.
*
IF (UPPER) THEN
DO 70 J = 1,N
DO 60 I = 1,M
TEMP1 = ALPHA*B(I,J)
TEMP2 = ZERO
DO 50 K = 1,I - 1
C(K,J) = C(K,J) + TEMP1*A(K,I)
TEMP2 = TEMP2 + B(K,J)*A(K,I)
50 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) +
+ ALPHA*TEMP2
END IF
60 CONTINUE
70 CONTINUE
ELSE
DO 100 J = 1,N
DO 90 I = M,1,-1
TEMP1 = ALPHA*B(I,J)
TEMP2 = ZERO
DO 80 K = I + 1,M
C(K,J) = C(K,J) + TEMP1*A(K,I)
TEMP2 = TEMP2 + B(K,J)*A(K,I)
80 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2
ELSE
C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) +
+ ALPHA*TEMP2
END IF
90 CONTINUE
100 CONTINUE
END IF
ELSE
*
* Form C := alpha*B*A + beta*C.
*
DO 170 J = 1,N
TEMP1 = ALPHA*A(J,J)
IF (BETA.EQ.ZERO) THEN
DO 110 I = 1,M
C(I,J) = TEMP1*B(I,J)
110 CONTINUE
ELSE
DO 120 I = 1,M
C(I,J) = BETA*C(I,J) + TEMP1*B(I,J)
120 CONTINUE
END IF
DO 140 K = 1,J - 1
IF (UPPER) THEN
TEMP1 = ALPHA*A(K,J)
ELSE
TEMP1 = ALPHA*A(J,K)
END IF
DO 130 I = 1,M
C(I,J) = C(I,J) + TEMP1*B(I,K)
130 CONTINUE
140 CONTINUE
DO 160 K = J + 1,N
IF (UPPER) THEN
TEMP1 = ALPHA*A(J,K)
ELSE
TEMP1 = ALPHA*A(K,J)
END IF
DO 150 I = 1,M
C(I,J) = C(I,J) + TEMP1*B(I,K)
150 CONTINUE
160 CONTINUE
170 CONTINUE
END IF
*
RETURN
*
* End of CSYMM
*
END
*/
void csymm(char side, char uplo, int m, int n, complex float alpha, complex float *a, int lda, complex float *b, int ldb, complex float beta, complex float *c, int ldc) {
// -- Reference BLAS level3 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float temp1, temp2;
int i, info, j, k, nrowa;
bool upper;
// Set NROWA as the number of rows of A.
nrowa = (side == 'L') ? m : n;
upper = (uplo == 'U');
// Test the input parameters.
info = 0;
if (side != 'L' && side != 'R') {
info = 1;
} else if (!upper && uplo != 'U') {
info = 2;
} else if (m < 0) {
info = 3;
} else if (n < 0) {
info = 4;
} else if (lda < fmax(1, nrowa)) {
info = 7;
} else if (ldb < fmax(1, m)) {
info = 9;
} else if (ldc < fmax(1, m)) {
info = 12;
}
if (info != 0) {
xerbla("CSYMM ", info);
return;
}
// Quick return if possible.
if (m == 0 || n == 0 || (alpha == 0.0 && beta == 1.0)) return;
// And when alpha == 0.
if (alpha == 0.0) {
if (beta == 0.0) {
for (j = 0; j < n; j++) {
for (i = 0; i < m; i++) {
c[i + j * ldc] = 0.0;
}
}
} else {
for (j = 0; j < n; j++) {
for (i = 0; i < m; i++) {
c[i + j * ldc] *= beta;
}
}
}
return;
}
// Start the operations.
if (side == 'L') {
// Form C := alpha*A*B + beta*C.
if (upper) {
for (j = 0; j < n; j++) {
for (i = 0; i < m; i++) {
temp1 = alpha * b[i + j * ldb];
temp2 = 0.0;
for (k = 0; k < i; k++) {
c[k + j * ldc] += temp1 * a[k + i * lda];
temp2 += b[k + j * ldb] * a[k + i * lda];
}
if (beta == 0.0) {
c[i + j * ldc] = temp1 * a[i + i * lda] + alpha * temp2;
} else {
c[i + j * ldc] = beta * c[i + j * ldc] + temp1 * a[i + i * lda] + alpha * temp2;
}
}
}
} else {
for (j = 0; j < n; j++) {
for (i = m - 1; i >= 0; i--) {
temp1 = alpha * b[i + j * ldb];
temp2 = 0.0;
for (k = i + 1; k < m; k++) {
c[k + j * ldc] += temp1 * a[k + i * lda];
temp2 += b[k + j * ldb] * a[k + i * lda];
}
if (beta == 0.0) {
c[i + j * ldc] = temp1 * a[i + i * lda] + alpha * temp2;
} else {
c[i + j * ldc] = beta * c[i + j * ldc] + temp1 * a[i + i * lda] + alpha * temp2;
}
}
}
}
} else {
// Form C := alpha*B*A + beta*C.
for (j = 0; j < n; j++) {
temp1 = alpha * a[j + j * lda];
if (beta == 0.0) {
for (i = 0; i < m; i++) {
c[i + j * ldc] = temp1 * b[i + j * ldb];
}
} else {
for (i = 0; i < m; i++) {
c[i + j * ldc] = beta * c[i + j * ldc] + temp1 * b[i + j * ldb];
}
}
for (k = 0; k < j; k++) {
if (upper) {
temp1 = alpha * a[k + j * lda];
} else {
temp1 = alpha * a[j + k * lda];
}
for (i = 0; i < m; i++) {
c[i + j * ldc] += temp1 * b[i + k * ldb];
}
}
for (k = j + 1; k < n; k++) {
if (upper) {
temp1 = alpha * a[j + k * lda];
} else {
temp1 = alpha * a[k + j * lda];
}
for (i = 0; i < m; i++) {
c[i + j * ldc] += temp1 * b[i + k * ldb];
}
}
}
}
// End of CSYMM
}

358
src/single/csyr2k.c Normal file
View file

@ -0,0 +1,358 @@
#include <math.h>
#include <stdbool.h>
#include <complex.h>
#include "blas_internal.h"
/*
*> \brief \b CSYR2K
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA,BETA
* INTEGER K,LDA,LDB,LDC,N
* CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CSYR2K performs one of the symmetric rank 2k operations
*>
*> C := alpha*A*B**T + alpha*B*A**T + beta*C,
*>
*> or
*>
*> C := alpha*A**T*B + alpha*B**T*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.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO 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.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' C := alpha*A*B**T + alpha*B*A**T +
*> beta*C.
*>
*> TRANS = 'T' or 't' C := alpha*A**T*B + alpha*B**T*A +
*> beta*C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix C. N must be
*> at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> 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', K specifies the number of rows of the
*> matrices A and B. K must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, ka ), where ka is
*> k when TRANS = 'N' or 'n', and is n otherwise.
*> 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.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA 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 ).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is COMPLEX array, dimension ( LDB, kb ), where kb is
*> k when TRANS = 'N' or 'n', and is n otherwise.
*> 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.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> On entry, LDB 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 ).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is COMPLEX
*> On entry, BETA specifies the scalar beta.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX array, dimension ( LDC, N )
*> 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.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> On entry, LDC specifies the first dimension of C as declared
*> in the calling (sub) program. LDC must be at least
*> max( 1, n ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level3
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 3 Blas routine.
*>
*> -- Written on 8-February-1989.
*> Jack Dongarra, Argonne National Laboratory.
*> Iain Duff, AERE Harwell.
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
*> Sven Hammarling, Numerical Algorithms Group Ltd.
*> \endverbatim
*>
* =====================================================================
*/
void csyr2k(char uplo, char trans, int n, int k, complex float alpha, complex float *a, int lda, complex float *b, int ldb, complex float beta, complex float *c, int ldc) {
// -- Reference BLAS level3 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float temp1, temp2;
int i, info, j, l, nrowa;
bool upper;
complex float one = CMPLXF(1.0, 0.0);
complex float zero = CMPLXF(0.0, 0.0);
if (trans == 'N') {
nrowa = n;
} else {
nrowa = k;
}
upper = (uplo == 'U');
// Test the input parameters
info = 0;
if (!upper && uplo != 'L') {
info = 1;
} else if (trans != 'N' && trans != 'T') {
info = 2;
} else if (n < 0) {
info = 3;
} else if (k < 0) {
info = 4;
} else if (lda < fmax(1, nrowa)) {
info = 7;
} else if (ldb < fmax(1, nrowa)) {
info = 9;
} else if (ldc < fmax(1, n)) {
info = 12;
}
if (info != 0) {
xerbla("CSYR2K", info);
return;
}
if ((n == 0) || (((creal(alpha) == 0.0 && cimag(alpha) == 0.0) || (k == 0)) && (creal(beta) == 1.0 && cimag(beta) == 0.0))) {
return;
}
if (creal(alpha) == 0.0 && cimag(alpha) == 0.0) {
if (upper) {
if (creal(beta) == 0.0 && cimag(beta) == 0.0) {
for (j = 0; j < n; j++) {
for (i = 0; i <= j; i++) {
c[i + j * ldc] = zero;
}
}
} else {
for (j = 0; j < n; j++) {
for (i = 0; i <= j; i++) {
c[i + j * ldc] = beta * c[i + j * ldc];
}
}
}
} else {
if (creal(beta) == 0.0 && cimag(beta) == 0.0) {
for (j = 0; j < n; j++) {
for (i = j; i < n; i++) {
c[i + j * ldc] = zero;
}
}
} else {
for (j = 0; j < n; j++) {
for (i = j; i < n; i++) {
c[i + j * ldc] = beta * c[i + j * ldc];
}
}
}
}
return;
}
if (trans == 'N') {
if (upper) {
for (j = 0; j < n; j++) {
if (creal(beta) == 0.0 && cimag(beta) == 0.0) {
for (i = 0; i <= j; i++) {
c[i + j * ldc] = zero;
}
} else if (creal(beta) != 1.0 || cimag(beta) != 0.0) {
for (i = 0; i <= j; i++) {
c[i + j * ldc] = beta * c[i + j * ldc];
}
}
for (l = 0; l < k; l++) {
if (creal(a[j + l * lda]) != 0.0 || cimag(a[j + l * lda]) != 0.0 || creal(b[j + l * ldb]) != 0.0 || cimag(b[j + l * ldb]) != 0.0) {
temp1 = alpha * b[j + l * ldb];
temp2 = alpha * a[j + l * lda];
for (i = 0; i <= j; i++) {
c[i + j * ldc] = c[i + j * ldc] + a[i + l * lda] * temp1 + b[i + l * ldb] * temp2;
}
}
}
}
} else {
for (j = 0; j < n; j++) {
if (creal(beta) == 0.0 && cimag(beta) == 0.0) {
for (i = j; i < n; i++) {
c[i + j * ldc] = zero;
}
} else if (creal(beta) != 1.0 || creal(beta) != 0.0) {
for (i = j; i < n; i++) {
c[i + j * ldc] = beta * c[i + j * ldc];
}
}
for (l = 0; l < k; l++) {
if (creal(a[j + l * lda]) != 0.0 || cimag(a[j + l * lda]) != 0.0 || creal(b[j + l * ldb]) != 0.0 || cimag(b[j + l * ldb]) != 0.0) {
temp1 = alpha * b[j + l * ldb];
temp2 = alpha * a[j + l * lda];
for (i = j; i < n; i++) {
c[i + j * ldc] = c[i + j * ldc] + a[i + l * lda] * temp1 + b[i + l * ldb] * temp2;
}
}
}
}
}
} else {
if (upper) {
for (j = 0; j < n; j++) {
for (i = 0; i <= j; i++) {
temp1 = zero;
temp2 = zero;
for (l = 0; l < k; l++) {
temp1 = temp1 + a[l + i * lda] * b[l + j * ldb];
temp2 = temp2 + b[l + i * ldb] * a[l + j * lda];
}
if (creal(beta) == 0.0 && cimag(beta) == 0.0) {
c[i + j * ldc] = alpha * temp1 + alpha * temp2;
} else {
c[i + j * ldc] = beta * c[i + j * ldc] + alpha * temp1 + alpha * temp2;
}
}
}
} else {
for (j = 0; j < n; j++) {
for (i = j; i < n; i++) {
temp1 = zero;
temp2 = zero;
for (l = 0; l < k; l++) {
temp1 = temp1 + a[l + i * lda] * b[l + j * ldb];
temp2 = temp2 + b[l + i * ldb] * a[l + j * lda];
}
if (creal(beta) == 0.0 && cimag(beta) == 0.0) {
c[i + j * ldc] = alpha * temp1 + alpha * temp2;
} else {
c[i + j * ldc] = beta * c[i + j * ldc] + alpha * temp1 + alpha * temp2;
}
}
}
}
}
// End of CSYR2K
}

329
src/single/csyrk.c Normal file
View file

@ -0,0 +1,329 @@
#include <math.h>
#include <stdbool.h>
#include <complex.h>
#include "blas_internal.h"
/*
*> \brief \b CSYRK
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA,BETA
* INTEGER K,LDA,LDC,N
* CHARACTER TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CSYRK performs one of the symmetric rank k operations
*>
*> C := alpha*A*A**T + beta*C,
*>
*> or
*>
*> C := alpha*A**T*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.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO 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.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' C := alpha*A*A**T + beta*C.
*>
*> TRANS = 'T' or 't' C := alpha*A**T*A + beta*C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix C. N must be
*> at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> 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.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, ka ), where ka is
*> k when TRANS = 'N' or 'n', and is n otherwise.
*> 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.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA 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 ).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is COMPLEX
*> On entry, BETA specifies the scalar beta.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is COMPLEX array, dimension ( LDC, N )
*> 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.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> On entry, LDC specifies the first dimension of C as declared
*> in the calling (sub) program. LDC must be at least
*> max( 1, n ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level3
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 3 Blas routine.
*>
*> -- Written on 8-February-1989.
*> Jack Dongarra, Argonne National Laboratory.
*> Iain Duff, AERE Harwell.
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
*> Sven Hammarling, Numerical Algorithms Group Ltd.
*> \endverbatim
*>
* =====================================================================
*/
void csyrk(char uplo, char trans, int n, int k, complex float alpha, complex float *a, int lda, complex float beta, complex float *c, int ldc) {
// -- Reference BLAS level3 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float temp;
int i, info, j, l, nrowa;
bool upper;
// Test the input parameters.
if (trans == 'N') {
nrowa = n;
} else {
nrowa = k;
}
upper = (uplo == 'U');
info = 0;
if ((!upper) && (uplo != 'l')) {
info = 1;
} else if ((trans != 'n') && (trans != 't')) {
info = 2;
} else if (n < 0) {
info = 3;
} else if (k < 0) {
info = 4;
} else if (lda < fmax(1, nrowa)) {
info = 7;
} else if (ldc < fmax(1, n)) {
info = 10;
}
if (info != 0) {
xerbla("csyrk ", info);
return;
}
// Quick return if possible.
if (n == 0 || ((alpha == 0 || k == 0) && beta == 1)) return;
// And when alpha == zero.
if (alpha == 0) {
if (upper) {
if (beta == 0) {
for (j = 0; j < n; j++) {
for (i = 0; i <= j; i++) {
c[i + j * ldc] = 0;
}
}
} else {
for (j = 0; j < n; j++) {
for (i = 0; i <= j; i++) {
c[i + j * ldc] = beta * c[i + j * ldc];
}
}
}
} else {
if (beta == 0) {
for (j = 0; j < n; j++) {
for (i = j; i < n; i++) {
c[i + j * ldc] = 0;
}
}
} else {
for (j = 0; j < n; j++) {
for (i = j; i < n; i++) {
c[i + j * ldc] = beta * c[i + j * ldc];
}
}
}
}
return;
}
// Start the operations.
if (trans == 'N') {
if (upper) {
for (j = 0; j < n; j++) {
if (beta == 0) {
for (i = 0; i <= j; i++) {
c[i + j * ldc] = 0;
}
} else if (beta != 1) {
for (i = 0; i <= j; i++) {
c[i + j * ldc] = beta * c[i + j * ldc];
}
}
for (l = 0; l < k; l++) {
if (a[j + l * lda] != 0) {
temp = alpha * a[j + l * lda];
for (i = 0; i <= j; i++) {
c[i + j * ldc] = c[i + j * ldc] + temp * a[i + l * lda];
}
}
}
}
} else {
for (j = 0; j < n; j++) {
if (beta == 0) {
for (i = j; i < n; i++) {
c[i + j * ldc] = 0;
}
} else if (beta != 1) {
for (i = j; i < n; i++) {
c[i + j * ldc] = beta * c[i + j * ldc];
}
}
for (l = 0; l < k; l++) {
if (a[j + l * lda] != 0) {
temp = alpha * a[j + l * lda];
for (i = j; i < n; i++) {
c[i + j * ldc] = c[i + j * ldc] + temp * a[i + l * lda];
}
}
}
}
}
} else {
// Form C := alpha*A**T*A + beta*C.
if (upper) {
for (j = 0; j < n; j++) {
for (i = 0; i <= j; i++) {
temp = 0;
for (l = 0; l < k; l++) {
temp = temp + a[l + i * lda] * a[l + j * lda];
}
if (beta == 0) {
c[i + j * ldc] = alpha * temp;
} else {
c[i + j * ldc] = alpha * temp + beta * c[i + j * ldc];
}
}
}
} else {
for (j = 0; j < n; j++) {
for (i = j; i < n; i++) {
temp = 0;
for (l = 0; l < k; l++) {
temp = temp + a[l + i * lda] * a[l + j * lda];
}
if (beta == 0) {
c[i + j * ldc] = alpha * temp;
} else {
c[i + j * ldc] = alpha * temp + beta * c[i + j * ldc];
}
}
}
}
}
// End of CSYRK.
}

427
src/single/ctbmv.c Normal file
View file

@ -0,0 +1,427 @@
#include <math.h>
#include <stdbool.h>
#include <complex.h>
#include "blas_internal.h"
/*
*> \brief \b CTBMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,K,LDA,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CTBMV performs one of the matrix-vector operations
*>
*> x := A*x, or x := A**T*x, or x := A**H*x,
*>
*> where x is an n element vector and A is an n by n unit, or non-unit,
*> upper or lower triangular band matrix, with ( k + 1 ) diagonals.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO 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.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' x := A*x.
*>
*> TRANS = 'T' or 't' x := A**T*x.
*>
*> TRANS = 'C' or 'c' x := A**H*x.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> On entry, DIAG 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.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> On entry with UPLO = 'U' or 'u', K specifies the number of
*> super-diagonals of the matrix A.
*> On entry with UPLO = 'L' or 'l', K specifies the number of
*> sub-diagonals of the matrix A.
*> K must satisfy 0 .le. K.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, N ).
*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
*> by n part of the array A must contain the upper triangular
*> band part of the matrix of coefficients, supplied column by
*> column, with the leading diagonal of the matrix in row
*> ( k + 1 ) of the array, the first super-diagonal starting at
*> position 2 in row k, and so on. The top left k by k triangle
*> of the array A is not referenced.
*> The following program segment will transfer an upper
*> triangular band matrix from conventional full matrix storage
*> to band storage:
*>
*> DO 20, J = 1, N
*> M = K + 1 - J
*> DO 10, I = MAX( 1, J - K ), J
*> A( M + I, J ) = matrix( I, J )
*> 10 CONTINUE
*> 20 CONTINUE
*>
*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
*> by n part of the array A must contain the lower triangular
*> band part of the matrix of coefficients, supplied column by
*> column, with the leading diagonal of the matrix in row 1 of
*> the array, the first sub-diagonal starting at position 1 in
*> row 2, and so on. The bottom right k by k triangle of the
*> array A is not referenced.
*> The following program segment will transfer a lower
*> triangular band matrix from conventional full matrix storage
*> to band storage:
*>
*> DO 20, J = 1, N
*> M = 1 - J
*> DO 10, I = J, MIN( N, J + K )
*> A( M + I, J ) = matrix( I, J )
*> 10 CONTINUE
*> 20 CONTINUE
*>
*> Note that when DIAG = 'U' or 'u' the elements of the array A
*> corresponding to the diagonal elements of the matrix are not
*> referenced, but are assumed to be unity.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> ( k + 1 ).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX array, 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
*> transformed vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
*/
void ctbmv(char uplo, char trans, char diag, int n, int k, complex float *a, int lda, complex float *x, int incx) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float zero = CMPLXF(0.0, 0.0);
complex float temp;
int i, info, ix, j, jx, kplus1, kx, l;
bool noconj, nounit;
// Test the input parameters.
info = 0;
if (uplo != 'U' && uplo != 'L') {
info = 1;
} else if (trans != 'N' && trans != 'T' && trans != 'C') {
info = 2;
} else if (diag != 'U' && diag != 'N') {
info = 3;
} else if (n < 0) {
info = 4;
} else if (k < 0) {
info = 5;
} else if (lda < (k + 1)) {
info = 7;
} else if (incx == 0) {
info = 9;
}
if (info != 0) {
xerbla("CTBMV ", info);
return;
}
// Quick return if possible.
if (n == 0) return;
noconj = lsame(trans, 'T');
nounit = lsame(diag, 'N');
// Set up the start point in X if the increment is not unity.
if (incx <= 0) {
kx = 1 - (n - 1) * incx;
} else if (incx != 1) {
kx = 1;
}
// Start the operations. In this version the elements of A are accessed sequentially with one pass through A.
if (lsame(trans, 'N')) {
// Form x := A*x.
if (lsame(uplo, 'U')) {
kplus1 = k + 1;
if (incx == 1) {
for (j = 0; j < n; j++) {
if (creal(x[j]) != 0.0 || cimag(x[j]) != 0.0) {
temp = x[j];
l = kplus1 - j;
for (i = fmax(0, j - k); i < j; i++) {
x[i] += temp * a[l + i + j * lda];
}
if (nounit) {
x[j] *= a[kplus1 + j * lda];
}
}
}
} else {
jx = kx;
for (j = 0; j < n; j++) {
if (creal(x[jx]) != 0.0 || cimag(x[jx]) != 0.0) {
temp = x[jx];
ix = kx;
l = kplus1 - j;
for (i = fmax(0, j - k); i < j; i++) {
x[ix] += temp * a[l + i + j * lda];
ix += incx;
}
if (nounit) {
x[jx] *= a[kplus1 + j * lda];
}
}
jx += incx;
if (j > k) {
kx += incx;
}
}
}
} else {
if (incx == 1) {
for (j = n - 1; j >= 0; j--) {
if (creal(x[j]) != 0.0 || cimag(x[j]) != 0.0) {
temp = x[j];
l = 1 - j;
for (i = fmin(n, j + k); i > j; i--) {
x[i] += temp * a[l + i + j * lda];
}
if (nounit) {
x[j] *= a[j * lda];
}
}
}
} else {
kx += (n - 1) * incx;
jx = kx;
for (j = n - 1; j >= 0; j--) {
if (cimag(x[jx]) != 0.0 || cimag(x[jx]) != 0.0) {
temp = x[jx];
ix = kx;
l = 1 - j;
for (i = fmin(n, j + k); i > j; i--) {
x[ix] += temp * a[l + i + j * lda];
ix -= incx;
}
if (nounit) {
x[jx] *= a[j * lda];
}
}
jx -= incx;
if ((n - j) >= k) {
kx -= incx;
}
}
}
}
} else {
// Form x := A**T*x or x := A**H*x.
if (lsame(uplo, 'U')) {
kplus1 = k + 1;
if (incx == 1) {
for (j = n - 1; j >= 0; j--) {
temp = x[j];
l = kplus1 - j;
if (noconj) {
if (nounit) {
temp *= a[kplus1 + j * lda];
}
for (i = j - 1; i >= fmax(0, j - k); i--) {
temp += a[l + i + j * lda] * x[i];
}
} else {
if (nounit) {
temp *= conj(a[kplus1 + j * lda]);
}
for (i = j - 1; i >= fmax(0, j - k); i--) {
temp += conj(a[l + i + j * lda]) * x[i];
}
}
x[j] = temp;
}
} else {
kx += (n - 1) * incx;
jx = kx;
for (j = n - 1; j >= 0; j--) {
temp = x[jx];
kx -= incx;
ix = kx;
l = kplus1 - j;
if (noconj) {
if (nounit) {
temp *= a[kplus1 + j * lda];
}
for (i = j - 1; i >= fmax(0, j - k); i--) {
temp += a[l + i + j * lda] * x[ix];
ix -= incx;
}
} else {
if (nounit) {
temp *= conj(a[kplus1 + j * lda]);
}
for (i = j - 1; i >= fmax(0, j - k); i--) {
temp += conj(a[l + i + j * lda]) * x[ix];
ix -= incx;
}
}
x[jx] = temp;
jx -= incx;
}
}
} else {
if (incx == 1) {
for (j = 0; j < n; j++) {
temp = x[j];
l = 1 - j;
if (noconj) {
if (nounit) {
temp *= a[j * lda];
}
for (i = j + 1; i < fmin(n, j + k); i++) {
temp += a[l + i + j * lda] * x[i];
}
} else {
if (nounit) {
temp *= conj(a[j * lda]);
}
for (i = j + 1; i < fmin(n, j + k); i++) {
temp += conj(a[l + i + j * lda]) * x[i];
}
}
x[j] = temp;
}
} else {
jx = kx;
for (j = 0; j < n; j++) {
temp = x[jx];
kx += incx;
ix = kx;
l = 1 - j;
if (noconj) {
if (nounit) {
temp *= a[j * lda];
}
for (i = j + 1; i < fmin(n, j + k); i++) {
temp += a[l + i + j * lda] * x[ix];
ix += incx;
}
} else {
if (nounit) {
temp *= conj(a[j * lda]);
}
for (i = j + 1; i < fmin(n, j + k); i++) {
temp += conj(a[l + i + j * lda]) * x[ix];
ix += incx;
}
}
x[jx] = temp;
jx += incx;
}
}
}
}
// End of CTBMV
}

432
src/single/ctbsv.c Normal file
View file

@ -0,0 +1,432 @@
#include <math.h>
#include <complex.h>
#include <stdbool.h>
#include "blas_internal.h"
/*
*> \brief \b CTBSV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,K,LDA,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CTBSV solves one of the systems of equations
*>
*> A*x = b, or A**T*x = b, or A**H*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 band matrix, with ( k + 1 )
*> diagonals.
*>
*> No test for singularity or near-singularity is included in this
*> routine. Such tests must be performed before calling this routine.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO 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.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the equations to be solved as
*> follows:
*>
*> TRANS = 'N' or 'n' A*x = b.
*>
*> TRANS = 'T' or 't' A**T*x = b.
*>
*> TRANS = 'C' or 'c' A**H*x = b.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> On entry, DIAG 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.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> On entry with UPLO = 'U' or 'u', K specifies the number of
*> super-diagonals of the matrix A.
*> On entry with UPLO = 'L' or 'l', K specifies the number of
*> sub-diagonals of the matrix A.
*> K must satisfy 0 .le. K.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, N )
*> Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
*> by n part of the array A must contain the upper triangular
*> band part of the matrix of coefficients, supplied column by
*> column, with the leading diagonal of the matrix in row
*> ( k + 1 ) of the array, the first super-diagonal starting at
*> position 2 in row k, and so on. The top left k by k triangle
*> of the array A is not referenced.
*> The following program segment will transfer an upper
*> triangular band matrix from conventional full matrix storage
*> to band storage:
*>
*> DO 20, J = 1, N
*> M = K + 1 - J
*> DO 10, I = MAX( 1, J - K ), J
*> A( M + I, J ) = matrix( I, J )
*> 10 CONTINUE
*> 20 CONTINUE
*>
*> Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
*> by n part of the array A must contain the lower triangular
*> band part of the matrix of coefficients, supplied column by
*> column, with the leading diagonal of the matrix in row 1 of
*> the array, the first sub-diagonal starting at position 1 in
*> row 2, and so on. The bottom right k by k triangle of the
*> array A is not referenced.
*> The following program segment will transfer a lower
*> triangular band matrix from conventional full matrix storage
*> to band storage:
*>
*> DO 20, J = 1, N
*> M = 1 - J
*> DO 10, I = J, MIN( N, J + K )
*> A( M + I, J ) = matrix( I, J )
*> 10 CONTINUE
*> 20 CONTINUE
*>
*> Note that when DIAG = 'U' or 'u' the elements of the array A
*> corresponding to the diagonal elements of the matrix are not
*> referenced, but are assumed to be unity.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> ( k + 1 ).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX array, 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.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
*/
void ctbsv(char uplo, char trans, char diag, int n, int k, complex float *a, int lda, complex float *x, int incx) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float zero = CMPLXF(0.0, 0.0);
complex float temp;
int i, info, ix, j, jx, kplus1, kx, l;
bool noconj, nounit;
// Test the input parameters.
info = 0;
if (uplo != 'U' && uplo != 'L') {
info = 1;
} else if (trans != 'N' && trans != 'T' && trans != 'C') {
info = 2;
} else if (diag != 'U' && diag != 'N') {
info = 3;
} else if (n < 0) {
info = 4;
} else if (k < 0) {
info = 5;
} else if (lda < (k + 1)) {
info = 7;
} else if (incx == 0) {
info = 9;
}
if (info != 0) {
xerbla("CTBSV ", info);
return;
}
// Quick return if possible.
if (n == 0) return;
noconj = lsame(trans, 'T');
nounit = lsame(diag, 'N');
// Set up the start point in X if the increment is not unity.
// This will be (N - 1) * INCX too small for descending loops.
if (incx <= 0) {
kx = 1 - (n - 1) * incx;
} else if (incx != 1) {
kx = 1;
}
// Start the operations. In this version, the elements of A are accessed
// by sequentially with one pass through A.
if (lsame(trans, 'N')) {
// Form x := inv(A) * x.
if (lsame(uplo, 'U')) {
kplus1 = k + 1;
if (incx == 1) {
for (j = n; j >= 1; j--) {
if (x[j] != zero) {
l = kplus1 - j;
if (nounit) {
x[j] = x[j] / a[kplus1 * lda + j];
}
temp = x[j];
for (i = j - 1; i >= fmax(1, j - k); i--) {
x[i] = x[i] - temp * a[(l + i) * lda + j];
}
}
}
} else {
kx = kx + (n - 1) * incx;
jx = kx;
for (j = n; j >= 1; j--) {
kx = kx - incx;
if (x[jx] != zero) {
ix = kx;
l = kplus1 - j;
if (nounit) {
x[jx] = x[jx] / a[kplus1 * lda + j];
}
temp = x[jx];
for (i = j - 1; i >= fmax(1, j - k); i--) {
x[ix] = x[ix] - temp * a[(l + i) * lda + j];
ix = ix - incx;
}
}
jx = jx - incx;
}
}
} else {
if (incx == 1) {
for (j = 1; j <= n; j++) {
if (x[j] != zero) {
l = 1 - j;
if (nounit) {
x[j] = x[j] / a[j];
}
temp = x[j];
for (i = j + 1; i <= fmin(n, j + k); i++) {
x[i] = x[i] - temp * a[(l + i) * lda + j];
}
}
}
} else {
jx = kx;
for (j = 1; j <= n; j++) {
kx = kx + incx;
if (x[jx] != zero) {
ix = kx;
l = 1 - j;
if (nounit) {
x[jx] = x[jx] / a[j];
}
temp = x[jx];
for (i = j + 1; i <= fmin(n, j + k); i++) {
x[ix] = x[ix] - temp * a[(l + i) * lda + j];
ix = ix + incx;
}
}
jx = jx + incx;
}
}
}
} else {
// Form x := inv(A^T) * x or x := inv(A^H) * x.
if (lsame(uplo, 'U')) {
kplus1 = k + 1;
if (incx == 1) {
for (j = 1; j <= n; j++) {
temp = x[j];
l = kplus1 - j;
if (noconj) {
for (i = fmax(1, j - k); i <= j - 1; i++) {
temp = temp - a[(l + i) * lda + j] * x[i];
}
if (nounit) {
temp = temp / a[kplus1 * lda + j];
}
} else {
for (i = fmax(1, j - k); i <= j - 1; i++) {
temp = temp - conj(a[(l + i) * lda + j]) * x[i];
}
if (nounit) {
temp = temp / conj(a[kplus1 * lda + j]);
}
}
x[j] = temp;
}
} else {
jx = kx;
for (j = 1; j <= n; j++) {
temp = x[jx];
ix = kx;
l = kplus1 - j;
if (noconj) {
for (i = fmax(1, j - k); i <= j - 1; i++) {
temp = temp - a[(l + i) * lda + j] * x[ix];
ix = ix + incx;
}
if (nounit) {
temp = temp / a[kplus1 * lda + j];
}
} else {
for (i = fmax(1, j - k); i <= j - 1; i++) {
temp = temp - conj(a[(l + i) * lda + j]) * x[ix];
ix = ix + incx;
}
if (nounit) {
temp = temp / conj(a[kplus1 * lda + j]);
}
}
x[jx] = temp;
jx = jx + incx;
if (j > k) {
kx = kx + incx;
}
}
}
} else {
if (incx == 1) {
for (j = n; j >= 1; j--) {
temp = x[j];
l = 1 - j;
if (noconj) {
for (i = fmin(n, j + k); i >= j + 1; i--) {
temp = temp - a[(l + i) * lda + j] * x[i];
}
if (nounit) {
temp = temp / a[j];
}
} else {
for (i = fmin(n, j + k); i >= j + 1; i--) {
temp = temp - conj(a[(l + i) * lda + j]) * x[i];
}
if (nounit) {
temp = temp / conj(a[j]);
}
}
x[j] = temp;
}
} else {
kx = kx + (n - 1) * incx;
jx = kx;
for (j = n; j >= 1; j--) {
temp = x[jx];
ix = kx;
l = 1 - j;
if (noconj) {
for (i = fmin(n, j + k); i >= j + 1; i--) {
temp = temp - a[(l + i) * lda + j] * x[ix];
ix = ix - incx;
}
if (nounit) {
temp = temp / a[j];
}
} else {
for (i = fmin(n, j + k); i >= j + 1; i--) {
temp = temp - conj(a[(l + i) * lda + j]) * x[ix];
ix = ix - incx;
}
if (nounit) {
temp = temp / conj(a[j]);
}
}
x[jx] = temp;
jx = jx - incx;
if ((n - j) >= k) {
kx = kx - incx;
}
}
}
}
}
// End of CTBSV
}

380
src/single/ctpmv.c Normal file
View file

@ -0,0 +1,380 @@
#include <complex.h>
#include <stdbool.h>
#include "blas_internal.h"
/*
*> \brief \b CTPMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX AP(*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CTPMV performs one of the matrix-vector operations
*>
*> x := A*x, or x := A**T*x, or x := A**H*x,
*>
*> where x is an n element vector and A is an n by n unit, or non-unit,
*> upper or lower triangular matrix, supplied in packed form.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO 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.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' x := A*x.
*>
*> TRANS = 'T' or 't' x := A**T*x.
*>
*> TRANS = 'C' or 'c' x := A**H*x.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> On entry, DIAG 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.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is COMPLEX array, dimension at least
*> ( ( n*( n + 1 ) )/2 ).
*> Before entry with UPLO = 'U' or 'u', the array AP must
*> contain the upper triangular matrix packed sequentially,
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
*> respectively, and so on.
*> Before entry with UPLO = 'L' or 'l', the array AP must
*> contain the lower triangular matrix packed sequentially,
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
*> respectively, and so on.
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
*> A are not referenced, but are assumed to be unity.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX array, 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
*> transformed vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
*/
void ctpmv(char uplo, char trans, char diag, int n, complex float *ap, complex float *x, int incx) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float zero = CMPLXF(0.0, 0.0);
int i, info, ix, j, jx, k, kk, kx;
bool noconj, nounit;
// Test the input parameters.
info = 0;
if (uplo != 'U' && uplo != 'L') {
info = 1;
} else if (trans != 'N' && trans != 'T' && trans != 'C') {
info = 2;
} else if (diag != 'U' && diag != 'N') {
info = 3;
} else if (n < 0) {
info = 4;
} else if (incx == 0) {
info = 7;
}
if (info != 0) {
xerbla("CTPMV ", info);
return;
}
// Quick return if possible.
if (n == 0) return;
noconj = lsame(trans, 'T');
nounit = lsame(diag, 'N');
// Set up the start point in X if the increment is not unity.
if (incx <= 0) {
kx = 1 - (n - 1) * incx;
} else if (incx != 1) {
kx = 1;
}
// Start the operations. In this version the elements of AP are accessed sequentially with one pass through AP.
if (lsame(trans, 'N')) {
// Form x := A*x.
if (lsame(uplo, 'U')) {
kk = 1;
if (incx == 1) {
for (j = 1; j <= n; j++) {
if (x[j] != zero) {
temp = x[j];
k = kk;
for (i = 1; i <= j - 1; i++) {
x[i] = x[i] + temp * ap[k];
k = k + 1;
}
if (nounit) {
x[j] = x[j] * ap[kk + j - 1];
}
}
kk = kk + j;
}
} else {
jx = kx;
for (j = 1; j <= n; j++) {
if (x[jx] != zero) {
temp = x[jx];
ix = kx;
for (k = kk; k <= kk + j - 2; k++) {
x[ix] = x[ix] + temp * ap[k];
ix = ix + incx;
}
if (nounit) {
x[jx] = x[jx] * ap[kk + j - 1];
}
}
jx = jx + incx;
kk = kk + j;
}
}
} else {
kk = (n * (n + 1)) / 2;
if (incx == 1) {
for (j = n; j >= 1; j--) {
if (x[j] != zero) {
temp = x[j];
k = kk;
for (i = n; i >= j + 1; i--) {
x[i] = x[i] + temp * ap[k];
k = k - 1;
}
if (nounit) {
x[j] = x[j] * ap[kk - n + j];
}
}
kk = kk - (n - j + 1);
}
} else {
kx = kx + (n - 1) * incx;
jx = kx;
for (j = n; j >= 1; j--) {
if (x[jx] != zero) {
temp = x[jx];
ix = kx;
for (k = kk; k >= kk - (n - (j + 1)); k--) {
x[ix] = x[ix] + temp * ap[k];
ix = ix - incx;
}
if (nounit) {
x[jx] = x[jx] * ap[kk - n + j];
}
}
jx = jx - incx;
kk = kk - (n - j + 1);
}
}
}
} else {
// Form x := A**T*x or x := A**H*x.
if (lsame(uplo, 'U')) {
kk = (n * (n + 1)) / 2;
if (incx == 1) {
for (j = n; j >= 1; j--) {
temp = x[j];
k = kk - 1;
if (noconj) {
if (nounit) {
temp = temp * ap[kk];
}
for (i = j - 1; i >= 1; i--) {
temp = temp + ap[k] * x[i];
k = k - 1;
}
} else {
if (nounit) {
temp = temp * conj(ap[kk]);
}
for (i = j - 1; i >= 1; i--) {
temp = temp + conj(ap[k]) * x[i];
k = k - 1;
}
}
x[j] = temp;
kk = kk - j;
}
} else {
jx = kx + (n - 1) * incx;
for (j = n; j >= 1; j--) {
temp = x[jx];
ix = jx;
if (noconj) {
if (nounit) {
temp = temp * ap[kk];
}
for (k = kk - 1; k >= kk - j + 1; k--) {
ix = ix - incx;
temp = temp + ap[k] * x[ix];
}
} else {
if (nounit) {
temp = temp * conj(ap[kk]);
}
for (k = kk - 1; k >= kk - j + 1; k--) {
ix = ix - incx;
temp = temp + conj(ap[k]) * x[ix];
}
}
x[jx] = temp;
jx = jx - incx;
kk = kk - j;
}
}
} else {
kk = 1;
if (incx == 1) {
for (j = 1; j <= n; j++) {
temp = x[j];
k = kk + 1;
if (noconj) {
if (nounit) {
temp = temp * ap[kk];
}
for (i = j + 1; i <= n; i++) {
temp = temp + ap[k] * x[i];
k = k + 1;
}
} else {
if (nounit) {
temp = temp * conj(ap[kk]);
}
for (i = j + 1; i <= n; i++) {
temp = temp + conj(ap[k]) * x[i];
k = k + 1;
}
}
x[j] = temp;
kk = kk + (n - j + 1);
}
} else {
jx = kx;
for (j = 1; j <= n; j++) {
temp = x[jx];
ix = jx;
if (noconj) {
if (nounit) {
temp = temp * ap[kk];
}
for (k = kk + 1; k <= kk + n - j; k++) {
ix = ix + incx;
temp = temp + ap[k] * x[ix];
}
} else {
if (nounit) {
temp = temp * conj(ap[kk]);
}
for (k = kk + 1; k <= kk + n - j; k++) {
ix = ix + incx;
temp = temp + conj(ap[k]) * x[ix];
}
}
x[jx] = temp;
jx = jx + incx;
kk = kk + (n - j + 1);
}
}
}
}
// End of CTPMV
}

385
src/single/ctpsv.c Normal file
View file

@ -0,0 +1,385 @@
#include <complex.h>
#include <stdbool.h>
#include "blas_internal.h"
/*
*> \brief \b CTPSV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX AP(*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CTPSV solves one of the systems of equations
*>
*> A*x = b, or A**T*x = b, or A**H*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, supplied in packed form.
*>
*> No test for singularity or near-singularity is included in this
*> routine. Such tests must be performed before calling this routine.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO 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.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the equations to be solved as
*> follows:
*>
*> TRANS = 'N' or 'n' A*x = b.
*>
*> TRANS = 'T' or 't' A**T*x = b.
*>
*> TRANS = 'C' or 'c' A**H*x = b.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> On entry, DIAG 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.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*> AP is COMPLEX array, dimension at least
*> ( ( n*( n + 1 ) )/2 ).
*> Before entry with UPLO = 'U' or 'u', the array AP must
*> contain the upper triangular matrix packed sequentially,
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
*> AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
*> respectively, and so on.
*> Before entry with UPLO = 'L' or 'l', the array AP must
*> contain the lower triangular matrix packed sequentially,
*> column by column, so that AP( 1 ) contains a( 1, 1 ),
*> AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
*> respectively, and so on.
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
*> A are not referenced, but are assumed to be unity.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX array, 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.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
*/
void ctpsv(char uplo, char trans, char diag, int n, complex float *ap, complex float *x, int incx) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float zero = CMPLXF(0.0, 0.0);
complex float temp;
int i, info, ix, j, jx, k, kk, kx;
bool noconj, nounit;
// Test the input parameters.
info = 0;
if (uplo != 'U' && uplo != 'L') {
info = 1;
} else if (trans != 'N' && trans != 'T' && trans != 'C') {
info = 2;
} else if (diag != 'U' && diag != 'N') {
info = 3;
} else if (n < 0) {
info = 4;
} else if (incx == 0) {
info = 7;
}
if (info != 0) {
xerbla("CTPSV ", info);
return;
}
// Quick return if possible.
if (n == 0) {
return;
}
noconj = lsame(trans, 'T');
nounit = lsame(diag, 'N');
// Set up the start point in X if the increment is not unity.
if (incx <= 0) {
kx = 1 - (n - 1) * incx;
} else if (incx != 1) {
kx = 1;
}
// Start the operations. In this version the elements of AP are accessed sequentially with one pass through AP.
if (lsame(trans, 'N')) {
// Form x := inv(A) * x.
if (lsame(uplo, 'U')) {
kk = (n * (n + 1)) / 2;
if (incx == 1) {
for (j = n; j >= 1; j--) {
if (x[j] != zero) {
if (nounit) {
x[j] = x[j] / ap[kk];
}
temp = x[j];
k = kk - 1;
for (i = j - 1; i >= 1; i--) {
x[i] = x[i] - temp * ap[k];
k = k - 1;
}
}
kk = kk - j;
}
} else {
jx = kx + (n - 1) * incx;
for (j = n; j >= 1; j--) {
if (x[jx] != zero) {
if (nounit) {
x[jx] = x[jx] / ap[kk];
}
temp = x[jx];
ix = jx;
for (k = kk - 1; k >= kk - j + 1; k--) {
ix = ix - incx;
x[ix] = x[ix] - temp * ap[k];
}
}
jx = jx - incx;
kk = kk - j;
}
}
} else {
kk = 1;
if (incx == 1) {
for (j = 1; j <= n; j++) {
if (x[j] != zero) {
if (nounit) {
x[j] = x[j] / ap[kk];
}
temp = x[j];
k = kk + 1;
for (i = j + 1; i <= n; i++) {
x[i] = x[i] - temp * ap[k];
k = k + 1;
}
}
kk = kk + (n - j + 1);
}
} else {
jx = kx;
for (j = 1; j <= n; j++) {
if (x[jx] != zero) {
if (nounit) {
x[jx] = x[jx] / ap[kk];
}
temp = x[jx];
ix = jx;
for (k = kk + 1; k <= kk + n - j; k++) {
ix = ix + incx;
x[ix] = x[ix] - temp * ap[k];
}
}
jx = jx + incx;
kk = kk + (n - j + 1);
}
}
}
} else {
// Form x := inv(A^T) * x or x := inv(A^H) * x.
if (lsame(uplo, 'U')) {
kk = 1;
if (incx == 1) {
for (j = 1; j <= n; j++) {
temp = x[j];
k = kk;
if (noconj) {
for (i = 1; i <= j - 1; i++) {
temp = temp - ap[k] * x[i];
k = k + 1;
}
if (nounit) {
temp = temp / ap[kk + j - 1];
}
} else {
for (i = 1; i <= j - 1; i++) {
temp = temp - conj(ap[k]) * x[i];
k = k + 1;
}
if (nounit) {
temp = temp / conj(ap[kk + j - 1]);
}
}
x[j] = temp;
kk = kk + j;
}
} else {
jx = kx;
for (j = 1; j <= n; j++) {
temp = x[jx];
ix = kx;
if (noconj) {
for (k = kk; k <= kk + j - 2; k++) {
temp = temp - ap[k] * x[ix];
ix = ix + incx;
}
if (nounit) {
temp = temp / ap[kk + j - 1];
}
} else {
for (k = kk; k <= kk + j - 2; k++) {
temp = temp - conj(ap[k]) * x[ix];
ix = ix + incx;
}
if (nounit) {
temp = temp / conj(ap[kk + j - 1]);
}
}
x[jx] = temp;
jx = jx + incx;
kk = kk + j;
}
}
} else {
kk = (n * (n + 1)) / 2;
if (incx == 1) {
for (j = n; j >= 1; j--) {
temp = x[j];
k = kk;
if (noconj) {
for (i = n; i >= j + 1; i--) {
temp = temp - ap[k] * x[i];
k = k - 1;
}
if (nounit) {
temp = temp / ap[kk - n + j];
}
} else {
for (i = n; i >= j + 1; i--) {
temp = temp - conj(ap[k]) * x[i];
k = k - 1;
}
if (nounit) {
temp = temp / conj(ap[kk - n + j]);
}
}
x[j] = temp;
kk = kk - (n - j + 1);
}
} else {
kx = kx + (n - 1) * incx;
jx = kx;
for (j = n; j >= 1; j--) {
temp = x[jx];
ix = kx;
if (noconj) {
for (k = kk; k >= kk - (n - (j + 1)); k--) {
temp = temp - ap[k] * x[ix];
ix = ix - incx;
}
if (nounit) {
temp = temp / ap[kk - n + j];
}
} else {
for (k = kk; k >= kk - (n - (j + 1)); k--) {
temp = temp - conj(ap[k]) * x[ix];
ix = ix - incx;
}
if (nounit) {
temp = temp / conj(ap[kk - n + j]);
}
}
x[jx] = temp;
jx = jx - incx;
kk = kk - (n - j + 1);
}
}
}
}
// End of CTPSV
}

427
src/single/ctrmm.c Normal file
View file

@ -0,0 +1,427 @@
#include <math.h>
#include <complex.h>
#include <stdbool.h>
#include "blas_internal.h"
/*
*> \brief \b CTRMM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA
* INTEGER LDA,LDB,M,N
* CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),B(LDB,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CTRMM performs one of the matrix-matrix operations
*>
*> B := alpha*op( A )*B, or B := alpha*B*op( A )
*>
*> where alpha is a scalar, B is an m by n matrix, A is a unit, or
*> non-unit, upper or lower triangular matrix and op( A ) is one of
*>
*> op( A ) = A or op( A ) = A**T or op( A ) = A**H.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> On entry, SIDE specifies whether op( A ) multiplies B from
*> the left or right as follows:
*>
*> SIDE = 'L' or 'l' B := alpha*op( A )*B.
*>
*> SIDE = 'R' or 'r' B := alpha*B*op( A ).
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the matrix A 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.
*> \endverbatim
*>
*> \param[in] TRANSA
*> \verbatim
*> TRANSA is CHARACTER*1
*> On entry, TRANSA 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**T.
*>
*> TRANSA = 'C' or 'c' op( A ) = A**H.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> On entry, DIAG 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.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of B. M must be at
*> least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of B. N must be
*> at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha. When alpha is
*> zero then A is not referenced and B need not be set before
*> entry.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, k ), where k is m
*> when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
*> Before entry with UPLO = 'U' or 'u', the leading k by k
*> 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 k by k
*> 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.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA 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 ), when SIDE = 'R' or 'r'
*> then LDA must be at least max( 1, n ).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX array, dimension ( LDB, N ).
*> Before entry, the leading m by n part of the array B must
*> contain the matrix B, and on exit is overwritten by the
*> transformed matrix.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> On entry, LDB specifies the first dimension of B as declared
*> in the calling (sub) program. LDB must be at least
*> max( 1, m ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level3
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 3 Blas routine.
*>
*> -- Written on 8-February-1989.
*> Jack Dongarra, Argonne National Laboratory.
*> Iain Duff, AERE Harwell.
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
*> Sven Hammarling, Numerical Algorithms Group Ltd.
*> \endverbatim
*>
* =====================================================================
*/
void ctrmm(char side, char uplo, char transa, char diag, int m, int n, complex float alpha, complex float *a, int lda, complex float *b, int ldb) {
// -- Reference BLAS level3 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float temp;
int i, info, j, k, nrowa;
bool lside, noconj, nounit, upper;
// Test the input parameters
if (side == 'L' || side == 'l') {
lside = true;
nrowa = m;
} else {
lside = false;
nrowa = n;
}
noconj = (transa == 'T' || transa == 't');
nounit = (diag == 'N' || diag == 'n');
upper = (uplo == 'U' || uplo == 'u');
info = 0;
if ((!lside) && (side != 'R')) {
info = 1;
} else if ((!upper) && (uplo != 'L')) {
info = 2;
} else if ((transa != 'N') && (transa != 'T') && (transa != 'C')) {
info = 3;
} else if ((diag != 'U') && (diag != 'N')) {
info = 4;
} else if (m < 0) {
info = 5;
} else if (n < 0) {
info = 6;
} else if (lda < fmax(1, nrowa)) {
info = 9;
} else if (ldb < fmax(1, m)) {
info = 11;
}
if (info != 0) {
xerbla("CTRMM ", info);
return;
}
// Quick return if possible
if (m == 0 || n == 0) return;
if (alpha == 0.0) {
for (j = 0; j < n; j++) {
for (i = 0; i < m; i++) {
b[i + j * ldb] = 0.0;
}
}
return;
}
if (lside) {
if (transa == 'N' || transa == 'n') {
if (upper) {
for (j = 0; j < n; j++) {
for (k = 0; k < m; k++) {
if (b[k + j * ldb] != 0.0) {
temp = alpha * b[k + j * ldb];
for (i = 0; i < k; i++) {
b[i + j * ldb] += temp * a[i + k * lda];
}
if (nounit) {
temp *= a[k + k * lda];
}
b[k + j * ldb] = temp;
}
}
}
} else {
for (j = 0; j < n; j++) {
for (k = m - 1; k >= 0; k--) {
if (b[k + j * ldb] != 0.0) {
temp = alpha * b[k + j * ldb];
b[k + j * ldb] = temp;
if (nounit) {
b[k + j * ldb] *= a[k + k * lda];
}
for (i = k + 1; i < m; i++) {
b[i + j * ldb] += temp * a[i + k * lda];
}
}
}
}
}
} else {
if (upper) {
for (j = 0; j < n; j++) {
for (i = m - 1; i >= 0; i--) {
temp = b[i + j * ldb];
if (noconj) {
if (nounit) {
temp *= a[i + i * lda];
}
for (k = 0; k < i; k++) {
temp += a[k + i * lda] * b[k + j * ldb];
}
} else {
if (nounit) {
temp *= conj(a[i + i * lda]);
}
for (k = 0; k < i; k++) {
temp += conj(a[k + i * lda]) * b[k + j * ldb];
}
}
b[i + j * ldb] = alpha * temp;
}
}
} else {
for (j = 0; j < n; j++) {
for (i = 0; i < m; i++) {
temp = b[i + j * ldb];
if (noconj) {
if (nounit) {
temp *= a[i + i * lda];
}
for (k = i + 1; k < m; k++) {
temp += a[k + i * lda] * b[k + j * ldb];
}
} else {
if (nounit) {
temp *= conj(a[i + i * lda]);
}
for (k = i + 1; k < m; k++) {
temp += conj(a[k + i * lda]) * b[k + j * ldb];
}
}
b[i + j * ldb] = alpha * temp;
}
}
}
}
} else {
if (transa == 'N' || transa == 'n') {
if (upper) {
for (j = n - 1; j >= 0; j--) {
temp = alpha;
if (nounit) {
temp *= a[j + j * lda];
}
for (i = 0; i < m; i++) {
b[i + j * ldb] *= temp;
}
for (k = 0; k < j; k++) {
if (a[k + j * lda] != 0.0) {
temp = alpha * a[k + j * lda];
for (i = 0; i < m; i++) {
b[i + j * ldb] += temp * b[i + k * ldb];
}
}
}
}
} else {
for (j = 0; j < n; j++) {
temp = alpha;
if (nounit) {
temp *= a[j + j * lda];
}
for (i = 0; i < m; i++) {
b[i + j * ldb] *= temp;
}
for (k = j + 1; k < n; k++) {
if (a[k + j * lda] != 0.0) {
temp = alpha * a[k + j * lda];
for (i = 0; i < m; i++) {
b[i + j * ldb] += temp * b[i + k * ldb];
}
}
}
}
}
} else {
if (upper) {
for (k = 0; k < n; k++) {
for (j = 0; j < k; j++) {
if (a[j + k * lda] != 0.0) {
if (noconj) {
temp = alpha * a[j + k * lda];
} else {
temp = alpha * conj(a[j + k * lda]);
}
for (i = 0; i < m; i++) {
b[i + j * ldb] += temp * b[i + k * ldb];
}
}
}
temp = alpha;
if (nounit) {
if (noconj) {
temp *= a[k + k * lda];
} else {
temp *= conj(a[k + k * lda]);
}
}
if (temp != 1.0) {
for (i = 0; i < m; i++) {
b[i + k * ldb] *= temp;
}
}
}
} else {
for (k = n - 1; k >= 0; k--) {
for (j = k + 1; j < n; j++) {
if (a[j + k * lda] != 0.0) {
if (noconj) {
temp = alpha * a[j + k * lda];
} else {
temp = alpha * conj(a[j + k * lda]);
}
for (i = 0; i < m; i++) {
b[i + j * ldb] += temp * b[i + k * ldb];
}
}
}
temp = alpha;
if (nounit) {
if (noconj) {
temp *= a[k + k * lda];
} else {
temp *= conj(a[k + k * lda]);
}
}
if (temp != 1.0) {
for (i = 0; i < m; i++) {
b[i + k * ldb] *= temp;
}
}
}
}
}
}
// End of CTRMM
}

370
src/single/ctrmv.c Normal file
View file

@ -0,0 +1,370 @@
#include <math.h>
#include <complex.h>
#include <stdbool.h>
#include "blas_internal.h"
/*
*> \brief \b CTRMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,LDA,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CTRMV performs one of the matrix-vector operations
*>
*> x := A*x, or x := A**T*x, or x := A**H*x,
*>
*> where x is an n element vector and A is an n by n unit, or non-unit,
*> upper or lower triangular matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO 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.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' x := A*x.
*>
*> TRANS = 'T' or 't' x := A**T*x.
*>
*> TRANS = 'C' or 'c' x := A**H*x.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> On entry, DIAG 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.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, N ).
*> 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.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> max( 1, n ).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX array, 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
*> transformed vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
*/
void ctrmv(char uplo, char trans, char diag, int n, complex float *a, int lda, complex float *x, int incx) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float zero = CMPLXF(0.0, 0.0);
complex float temp;
int i, info, ix, j, jx, kx;
bool noconj, nounit;
// Test the input parameters.
info = 0;
if (uplo != 'U' && uplo != 'L') {
info = 1;
} else if (trans != 'N' && trans != 'T' && trans != 'C') {
info = 2;
} else if (diag != 'U' && diag != 'N') {
info = 3;
} else if (n < 0) {
info = 4;
} else if (lda < fmax(1, n)) {
info = 6;
} else if (incx == 0) {
info = 8;
}
if (info != 0) {
xerbla("CTRMV ", info);
return;
}
// Quick return if possible.
if (n == 0) {
return;
}
noconj = lsame(trans, 'T');
nounit = lsame(diag, 'N');
// Set up the start point in x if the increment is not unity.
// This will be (n - 1) * incx too small for descending loops.
if (incx <= 0) {
kx = 1 - (n - 1) * incx;
} else if (incx != 1) {
kx = 1;
}
// Start the operations. In this version, the elements of A are accessed sequentially with one pass through A.
if (lsame(trans, 'N')) {
// Form x := A * x.
if (lsame(uplo, 'U')) {
if (incx == 1) {
for (j = 0; j < n; j++) {
if (x[j] != zero) {
temp = x[j];
for (i = 0; i < j; i++) {
x[i] = x[i] + temp * a[i * lda + j];
}
if (nounit) {
x[j] = x[j] * a[j * lda + j];
}
}
}
} else {
jx = kx;
for (j = 0; j < n; j++) {
if (x[jx] != zero) {
temp = x[jx];
ix = kx;
for (i = 0; i < j; i++) {
x[ix] = x[ix] + temp * a[i * lda + j];
ix = ix + incx;
}
if (nounit) {
x[jx] = x[jx] * a[j * lda + j];
}
}
jx = jx + incx;
}
}
} else {
if (incx == 1) {
for (j = n - 1; j >= 0; j--) {
if (x[j] != zero) {
temp = x[j];
for (i = n - 1; i >= j + 1; i--) {
x[i] = x[i] + temp * a[i * lda + j];
}
if (nounit) {
x[j] = x[j] * a[j * lda + j];
}
}
}
} else {
kx = kx + (n - 1) * incx;
jx = kx;
for (j = n - 1; j >= 0; j--) {
if (x[jx] != zero) {
temp = x[jx];
ix = kx;
for (i = n - 1; i >= j + 1; i--) {
x[ix] = x[ix] + temp * a[i * lda + j];
ix = ix - incx;
}
if (nounit) {
x[jx] = x[jx] * a[j * lda + j];
}
}
jx = jx - incx;
}
}
}
} else {
// Form x := A^T * x or x := A^H * x.
if (lsame(uplo, 'U')) {
if (incx == 1) {
for (j = n - 1; j >= 0; j--) {
temp = x[j];
if (noconj) {
if (nounit) {
temp = temp * a[j * lda + j];
}
for (i = j - 1; i >= 0; i--) {
temp = temp + a[i * lda + j] * x[i];
}
} else {
if (nounit) {
temp = temp * conj(a[j * lda + j]);
}
for (i = j - 1; i >= 0; i--) {
temp = temp + conj(a[i * lda + j]) * x[i];
}
}
x[j] = temp;
}
} else {
jx = kx + (n - 1) * incx;
for (j = n - 1; j >= 0; j--) {
temp = x[jx];
ix = jx;
if (noconj) {
if (nounit) {
temp = temp * a[j * lda + j];
}
for (i = j - 1; i >= 0; i--) {
ix = ix - incx;
temp = temp + a[i * lda + j] * x[ix];
}
} else {
if (nounit) {
temp = temp * conj(a[j * lda + j]);
}
for (i = j - 1; i >= 0; i--) {
ix = ix - incx;
temp = temp + conj(a[i * lda + j]) * x[ix];
}
}
x[jx] = temp;
jx = jx - incx;
}
}
} else {
if (incx == 1) {
for (j = 0; j < n; j++) {
temp = x[j];
if (noconj) {
if (nounit) {
temp = temp * a[j * lda + j];
}
for (i = j + 1; i < n; i++) {
temp = temp + a[i * lda + j] * x[i];
}
} else {
if (nounit) {
temp = temp * conj(a[j * lda + j]);
}
for (i = j + 1; i < n; i++) {
temp = temp + conj(a[i * lda + j]) * x[i];
}
}
x[j] = temp;
}
} else {
jx = kx;
for (j = 0; j < n; j++) {
temp = x[jx];
ix = jx;
if (noconj) {
if (nounit) {
temp = temp * a[j * lda + j];
}
for (i = j + 1; i < n; i++) {
ix = ix + incx;
temp = temp + a[i * lda + j] * x[ix];
}
} else {
if (nounit) {
temp = temp * conj(a[j * lda + j]);
}
for (i = j + 1; i < n; i++) {
ix = ix + incx;
temp = temp + conj(a[i * lda + j]) * x[ix];
}
}
x[jx] = temp;
jx = jx + incx;
}
}
}
}
// End of CTRMV .
}

444
src/single/ctrsm.c Normal file
View file

@ -0,0 +1,444 @@
#include <math.h>
#include <complex.h>
#include <stdbool.h>
#include "blas_internal.h"
/*
*> \brief \b CTRSM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*
* .. Scalar Arguments ..
* COMPLEX ALPHA
* INTEGER LDA,LDB,M,N
* CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),B(LDB,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CTRSM solves one of the matrix equations
*>
*> op( A )*X = alpha*B, or X*op( A ) = alpha*B,
*>
*> where alpha is a scalar, X and B are m by n matrices, A is a unit, or
*> non-unit, upper or lower triangular matrix and op( A ) is one of
*>
*> op( A ) = A or op( A ) = A**T or op( A ) = A**H.
*>
*> The matrix X is overwritten on B.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> On entry, SIDE specifies whether op( A ) appears on the left
*> or right of X as follows:
*>
*> SIDE = 'L' or 'l' op( A )*X = alpha*B.
*>
*> SIDE = 'R' or 'r' X*op( A ) = alpha*B.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the matrix A 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.
*> \endverbatim
*>
*> \param[in] TRANSA
*> \verbatim
*> TRANSA is CHARACTER*1
*> On entry, TRANSA 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**T.
*>
*> TRANSA = 'C' or 'c' op( A ) = A**H.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> On entry, DIAG 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.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of B. M must be at
*> least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of B. N must be
*> at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is COMPLEX
*> On entry, ALPHA specifies the scalar alpha. When alpha is
*> zero then A is not referenced and B need not be set before
*> entry.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, k ),
*> where k is m when SIDE = 'L' or 'l'
*> and k is n when SIDE = 'R' or 'r'.
*> Before entry with UPLO = 'U' or 'u', the leading k by k
*> 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 k by k
*> 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.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA 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 ), when SIDE = 'R' or 'r'
*> then LDA must be at least max( 1, n ).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is COMPLEX array, dimension ( LDB, N )
*> Before entry, the leading m by n part of the array B must
*> contain the right-hand side matrix B, and on exit is
*> overwritten by the solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> On entry, LDB specifies the first dimension of B as declared
*> in the calling (sub) program. LDB must be at least
*> max( 1, m ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level3
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 3 Blas routine.
*>
*> -- Written on 8-February-1989.
*> Jack Dongarra, Argonne National Laboratory.
*> Iain Duff, AERE Harwell.
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
*> Sven Hammarling, Numerical Algorithms Group Ltd.
*> \endverbatim
*>
* =====================================================================
*/
void ctrsm(char side, char uplo, char transa, char diag, int m, int n, complex float alpha, complex float *a, int lda, complex float *b, int ldb) {
// -- Reference BLAS level3 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float temp;
int i, info, j, k, nrowa;
bool lside, noconj, nounit, upper;
// Test the input parameters.
lside = (side == 'l');
nrowa = lside ? m : n;
noconj = (transa == 'n');
nounit = (diag == 'n');
upper = (uplo == 'u');
info = 0;
if ((!lside) && (side != 'R')) {
info = 1;
} else if ((!upper) && (uplo != 'L')) {
info = 2;
} else if ((transa != 'N') && (transa != 'T') && (transa != 'C')) {
info = 3;
} else if ((diag != 'U') && (diag != 'N')) {
info = 4;
} else if (m < 0) {
info = 5;
} else if (n < 0) {
info = 6;
} else if (lda < fmax(1, nrowa)) {
info = 9;
} else if (ldb < fmax(1, m)) {
info = 11;
}
if (info != 0) {
xerbla("CTRSM ", info);
return;
}
// Quick return if possible.
if (m == 0 || n == 0) {
return;
}
// And when alpha.eq.zero.
if (alpha == 0) {
for (j = 0; j < n; j++) {
for (i = 0; i < m; i++) {
b[i + j * ldb] = 0;
}
}
return;
}
// Start the operations.
if (lside) {
if (transa == 'n') {
// Form B := alpha*inv( A )*B.
if (upper) {
for (j = 0; j < n; j++) {
if (alpha != 1) {
for (i = 0; i < m; i++) {
b[i + j * ldb] *= alpha;
}
}
for (k = m - 1; k >= 0; k--) {
if (b[k + j * ldb] != 0) {
if (nounit) {
b[k + j * ldb] /= a[k + k * lda];
}
for (i = 0; i < k; i++) {
b[i + j * ldb] -= b[k + j * ldb] * a[i + k * lda];
}
}
}
}
} else {
for (j = 0; j < n; j++) {
if (alpha != 1) {
for (i = 0; i < m; i++) {
b[i + j * ldb] *= alpha;
}
}
for (k = 0; k < m; k++) {
if (b[k + j * ldb] != 0) {
if (nounit) {
b[k + j * ldb] /= a[k + k * lda];
}
for (i = k + 1; i < m; i++) {
b[i + j * ldb] -= b[k + j * ldb] * a[i + k * lda];
}
}
}
}
}
} else {
// Form B := alpha*inv( A**T )*B or B := alpha*inv( A**H )*B.
if (upper) {
for (j = 0; j < n; j++) {
for (i = 0; i < m; i++) {
temp = alpha * b[i + j * ldb];
if (noconj) {
for (k = 0; k < i; k++) {
temp -= a[k + i * lda] * b[k + j * ldb];
}
if (nounit) {
temp /= a[i + i * lda];
}
} else {
for (k = 0; k < i; k++) {
temp -= conj(a[k + i * lda]) * b[k + j * ldb];
}
if (nounit) {
temp /= conj(a[i + i * lda]);
}
}
b[i + j * ldb] = temp;
}
}
} else {
for (j = 0; j < n; j++) {
for (i = m - 1; i >= 0; i--) {
temp = alpha * b[i + j * ldb];
if (noconj) {
for (k = i + 1; k < m; k++) {
temp -= a[k + i * lda] * b[k + j * ldb];
}
if (nounit) {
temp /= a[i + i * lda];
}
} else {
for (k = i + 1; k < m; k++) {
temp -= conj(a[k + i * lda]) * b[k + j * ldb];
}
if (nounit) {
temp /= conj(a[i + i * lda]);
}
}
b[i + j * ldb] = temp;
}
}
}
}
} else {
if (transa == 'n') {
// Form B := alpha*B*inv( A ).
if (upper) {
for (j = 0; j < n; j++) {
if (alpha != 1) {
for (i = 0; i < m; i++) {
b[i + j * ldb] *= alpha;
}
}
for (k = 0; k < j; k++) {
if (a[k + j * lda] != 0) {
for (i = 0; i < m; i++) {
b[i + j * ldb] -= a[k + j * lda] * b[i + k * ldb];
}
}
}
if (nounit) {
temp = 1 / a[j + j * lda];
for (i = 0; i < m; i++) {
b[i + j * ldb] *= temp;
}
}
}
} else {
for (j = n - 1; j >= 0; j--) {
if (alpha != 1) {
for (i = 0; i < m; i++) {
b[i + j * ldb] *= alpha;
}
}
for (k = j + 1; k < n; k++) {
if (a[k + j * lda] != 0) {
for (i = 0; i < m; i++) {
b[i + j * ldb] -= a[k + j * lda] * b[i + k * ldb];
}
}
}
if (nounit) {
temp = 1 / a[j + j * lda];
for (i = 0; i < m; i++) {
b[i + j * ldb] *= temp;
}
}
}
}
} else {
// Form B := alpha*B*inv( A**T ) or B := alpha*B*inv( A**H ).
if (upper) {
for (k = n - 1; k >= 0; k--) {
if (nounit) {
if (noconj) {
temp = 1 / a[k + k * lda];
} else {
temp = 1 / conj(a[k + k * lda]);
}
for (i = 0; i < m; i++) {
b[i + k * ldb] *= temp;
}
}
for (j = 0; j < k; j++) {
if (noconj) {
temp = a[j + k * lda];
} else {
temp = conj(a[j + k * lda]);
}
for (i = 0; i < m; i++) {
b[i + j * ldb] -= temp * b[i + k * ldb];
}
}
if (alpha != 1) {
for (i = 0; i < m; i++) {
b[i + k * ldb] *= alpha;
}
}
}
} else {
for (k = 0; k < n; k++) {
if (nounit) {
if (noconj) {
temp = 1 / a[k + k * lda];
} else {
temp = 1 / conj(a[k + k * lda]);
}
for (i = 0; i < m; i++) {
b[i + k * ldb] *= temp;
}
}
for (j = k + 1; j < n; j++) {
if (noconj) {
temp = a[j + k * lda];
} else {
temp = conj(a[j + k * lda]);
}
for (i = 0; i < m; i++) {
b[i + j * ldb] -= temp * b[i + k * ldb];
}
}
if (alpha != 1) {
for (i = 0; i < m; i++) {
b[i + k * ldb] *= alpha;
}
}
}
}
}
}
// End of CTRSM
}

372
src/single/ctrsv.c Normal file
View file

@ -0,0 +1,372 @@
#include <math.h>
#include <complex.h>
#include <stdbool.h>
#include "blas_internal.h"
/*
*> \brief \b CTRSV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE CTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,LDA,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> CTRSV solves one of the systems of equations
*>
*> A*x = b, or A**T*x = b, or A**H*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.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO 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.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the equations to be solved as
*> follows:
*>
*> TRANS = 'N' or 'n' A*x = b.
*>
*> TRANS = 'T' or 't' A**T*x = b.
*>
*> TRANS = 'C' or 'c' A**H*x = b.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> On entry, DIAG 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.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, N )
*> 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.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> max( 1, n ).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX array, 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.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
*/
void ctrsv(char uplo, char trans, char diag, int n, complex float *a, int lda, complex float *x, int incx) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
complex float zero = CMPLXF(0.0, 0.0);
complex float temp;
int i, info, ix, j, jx, kx;
bool noconj, nounit;
// Test the input parameters.
info = 0;
if (uplo != 'U' && uplo != 'L') {
info = 1;
} else if (trans != 'N' && trans != 'T' && trans != 'C') {
info = 2;
} else if (diag != 'U' && diag != 'N') {
info = 3;
} else if (n < 0) {
info = 4;
} else if (lda < fmax(1, n)) {
info = 6;
} else if (incx == 0) {
info = 8;
}
if (info != 0) {
xerbla("CTRSV ", info);
return;
}
// Quick return if possible.
if (n == 0) {
return;
}
noconj = lsame(trans, 'T');
nounit = lsame(diag, 'N');
// Set up the start point in X if the increment is not unity.
// This will be (N - 1) * INCX too small for descending loops.
if (incx <= 0) {
kx = 1 - (n - 1) * incx;
} else if (incx != 1) {
kx = 1;
}
// Start the operations. In this version, the elements of A are accessed sequentially with one pass through A.
if (lsame(trans, 'N')) {
// Form x := inv(A) * x.
if (lsame(uplo, 'U')) {
if (incx == 1) {
for (j = n; j >= 1; j--) {
if (x[j] != zero) {
if (nounit) {
x[j] = x[j] / a[j + j * lda];
}
temp = x[j];
for (i = j - 1; i >= 1; i--) {
x[i] = x[i] - temp * a[i + j * lda];
}
}
}
} else {
jx = kx + (n - 1) * incx;
for (j = n; j >= 1; j--) {
if (x[jx] != zero) {
if (nounit) {
x[jx] = x[jx] / a[j + j * lda];
}
temp = x[jx];
ix = jx;
for (i = j - 1; i >= 1; i--) {
ix = ix - incx;
x[ix] = x[ix] - temp * a[i + j * lda];
}
}
jx = jx - incx;
}
}
} else {
if (incx == 1) {
for (j = 1; j <= n; j++) {
if (x[j] != zero) {
if (nounit) {
x[j] = x[j] / a[j + j * lda];
}
temp = x[j];
for (i = j + 1; i <= n; i++) {
x[i] = x[i] - temp * a[i + j * lda];
}
}
}
} else {
jx = kx;
for (j = 1; j <= n; j++) {
if (x[jx] != zero) {
if (nounit) {
x[jx] = x[jx] / a[j + j * lda];
}
temp = x[jx];
ix = jx;
for (i = j + 1; i <= n; i++) {
ix = ix + incx;
x[ix] = x[ix] - temp * a[i + j * lda];
}
}
jx = jx + incx;
}
}
}
} else {
// Form x := inv(A^T) * x or x := inv(A^H) * x.
if (lsame(uplo, 'U')) {
if (incx == 1) {
for (j = 1; j <= n; j++) {
temp = x[j];
if (noconj) {
for (i = 1; i <= j - 1; i++) {
temp = temp - a[i + j * lda] * x[i];
}
if (nounit) {
temp = temp / a[j + j * lda];
}
} else {
for (i = 1; i <= j - 1; i++) {
temp = temp - conj(a[i + j * lda]) * x[i];
}
if (nounit) {
temp = temp / conj(a[j + j * lda]);
}
}
x[j] = temp;
}
} else {
jx = kx;
for (j = 1; j <= n; j++) {
ix = kx;
temp = x[jx];
if (noconj) {
for (i = 1; i <= j - 1; i++) {
temp = temp - a[i + j * lda] * x[ix];
ix = ix + incx;
}
if (nounit) {
temp = temp / a[j + j * lda];
}
} else {
for (i = 1; i <= j - 1; i++) {
temp = temp - conj(a[i + j * lda]) * x[ix];
ix = ix + incx;
}
if (nounit) {
temp = temp / conj(a[j + j * lda]);
}
}
x[jx] = temp;
jx = jx + incx;
}
}
} else {
if (incx == 1) {
for (j = n; j >= 1; j--) {
temp = x[j];
if (noconj) {
for (i = n; i >= j + 1; i--) {
temp = temp - a[i + j * lda] * x[i];
}
if (nounit) {
temp = temp / a[j + j * lda];
}
} else {
for (i = n; i >= j + 1; i--) {
temp = temp - conj(a[i + j * lda]) * x[i];
}
if (nounit) {
temp = temp / conj(a[j + j * lda]);
}
}
x[j] = temp;
}
} else {
kx = kx + (n - 1) * incx;
jx = kx;
for (j = n; j >= 1; j--) {
ix = kx;
temp = x[jx];
if (noconj) {
for (i = n; i >= j + 1; i--) {
temp = temp - a[i + j * lda] * x[ix];
ix = ix - incx;
}
if (nounit) {
temp = temp / a[j + j * lda];
}
} else {
for (i = n; i >= j + 1; i--) {
temp = temp - conj(a[i + j * lda]) * x[ix];
ix = ix - incx;
}
if (nounit) {
temp = temp / conj(a[j + j * lda]);
}
}
x[jx] = temp;
jx = jx - incx;
}
}
}
}
// End of CTRSV
}

132
src/single/icamax.c Normal file
View file

@ -0,0 +1,132 @@
#include <math.h>
#include <complex.h>
#include "blas_internal.h"
/*
*> \brief \b ICAMAX
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* INTEGER FUNCTION ICAMAX(N,CX,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* COMPLEX CX(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ICAMAX finds the index of the first element having maximum |Re(.)| + |Im(.)|
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] CX
*> \verbatim
*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of CX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup aux_blas
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 3/93 to return if incx .le. 0.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
*/
int icamax ( int n, complex float *x, int incx ) {
// -- Reference BLAS level1 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
float smax;
int i, ix, value;
value = 0;
if ( n < 1 || incx <= 0 ) {
return value;
}
value = 1;
if ( n == 1 ) {
return value;
}
if ( incx != 1 ) {
ix = 0;
smax = scabs1 ( x[0] );
ix = ix + incx;
for ( i = 1; i < n; i++ )
{
if ( smax < scabs1 ( x[ix] ) )
{
value = i + 1;
smax = scabs1 ( x[ix] );
}
ix = ix + incx;
}
}
else {
smax = scabs1 ( x[0] );
for ( i = 1; i < n; i++ )
{
if ( smax < scabs1 ( x[i] ) )
{
value = i + 1;
smax = scabs1 ( x[i] );
}
}
}
return value;
// End of ICAMAX
}

129
src/single/isamax.c Normal file
View file

@ -0,0 +1,129 @@
#include <math.h>
#include "blas_internal.h"
/*
*> \brief \b ISAMAX
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* INTEGER FUNCTION ISAMAX(N,SX,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* REAL SX(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ISAMAX finds the index of the first element having maximum absolute value.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] SX
*> \verbatim
*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of SX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup aux_blas
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 3/93 to return if incx .le. 0.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
*/
int isamax ( int n, float *dx, int incx ) {
// -- Reference BLAS level1 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
float dmax;
int i, ix, value;
value = 0;
if ( n < 1 || incx <= 0 ) {
return value;
}
value = 1;
if ( n == 1 ) {
return value;
}
if ( incx == 1 ) {
dmax = fabs ( dx[0] );
for ( i = 1; i < n; i++ ) {
if ( dmax < fabs ( dx[i] ) ) {
value = i + 1;
dmax = fabs ( dx[i] );
}
}
}
else {
ix = 0;
dmax = fabs ( dx[0] );
ix = ix + incx;
for ( i = 1; i < n; i++ ) {
if ( dmax < fabs ( dx[ix] ) ) {
value = i + 1;
dmax = fabs ( dx[ix] );
}
ix = ix + incx;
}
}
return value;
// End of ISAMAX
}

98
src/single/sasum.c Normal file
View file

@ -0,0 +1,98 @@
#include <math.h>
#include "blas_internal.h"
/*
*> \brief \b SASUM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* REAL FUNCTION SASUM(N,SX,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* REAL SX(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SASUM takes the sum of the absolute values.
*> uses unrolled loops for increment equal to one.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] SX
*> \verbatim
*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of SX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 3/93 to return if incx .le. 0.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
*/
float sasum ( int n, float *x, int incx ) {
// -- Reference BLAS level1 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
int i, j;
float value;
value = 0.0;
j = 0;
for ( i = 0; i < n; i++ ) {
value = value + fabs ( x[j] );
j = j + incx;
}
return value;
}

152
src/single/saxpy.c Normal file
View file

@ -0,0 +1,152 @@
#include "blas_internal.h"
/*
*> \brief \b SAXPY
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY)
*
* .. Scalar Arguments ..
* REAL SA
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* REAL SX(*),SY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SAXPY constant times a vector plus a vector.
*> uses unrolled loops for increments equal to one.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] SA
*> \verbatim
*> SA is REAL
*> On entry, SA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] SX
*> \verbatim
*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of SX
*> \endverbatim
*>
*> \param[in,out] SY
*> \verbatim
*> SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of SY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
*/
void saxpy ( int n, float da, float dx[], int incx, float dy[], int incy ) {
// -- Reference BLAS level1 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
int i, ix, iy, m;
if ( n <= 0 ) {
return;
}
if ( da == 0.0 ) {
return;
}
/*
Code for unequal increments or equal increments
not equal to 1.
*/
if ( incx != 1 || incy != 1 ) {
if ( 0 <= incx ) {
ix = 0;
}
else {
ix = ( - n + 1 ) * incx;
}
if ( 0 <= incy ) {
iy = 0;
}
else {
iy = ( - n + 1 ) * incy;
}
for ( i = 0; i < n; i++ ) {
dy[iy] = dy[iy] + da * dx[ix];
ix = ix + incx;
iy = iy + incy;
}
} else {
// Code for both increments equal to 1.
m = n % 4;
for ( i = 0; i < m; i++ ) {
dy[i] = dy[i] + da * dx[i];
}
for ( i = m; i < n; i = i + 4 ) {
dy[i ] = dy[i ] + da * dx[i ];
dy[i+1] = dy[i+1] + da * dx[i+1];
dy[i+2] = dy[i+2] + da * dx[i+2];
dy[i+3] = dy[i+3] + da * dx[i+3];
}
}
return;
}

59
src/single/scabs1.c Normal file
View file

@ -0,0 +1,59 @@
#include <math.h>
#include <complex.h>
#include "blas_internal.h"
/*
*> \brief \b SCABS1
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* REAL FUNCTION SCABS1(Z)
*
* .. Scalar Arguments ..
* COMPLEX Z
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SCABS1 computes |Re(.)| + |Im(.)| of a complex float number
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] Z
*> \verbatim
*> Z is COMPLEX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_blas_level1
*
* =====================================================================
*/
float scabs1 ( complex float z ) {
// -- Reference BLAS level1 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
return fabs ( creal ( z ) ) + fabs ( cimag ( z ) );
}

114
src/single/scasum.c Normal file
View file

@ -0,0 +1,114 @@
#include <math.h>
#include <complex.h>
#include "blas_internal.h"
/*
*> \brief \b SCASUM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* REAL FUNCTION SCASUM(N,CX,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* COMPLEX CX(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SCASUM takes the sum of the (|Re(.)| + |Im(.)|)'s of a complex vector and
*> returns a single precision result.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in,out] CX
*> \verbatim
*> CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of SX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 3/93 to return if incx .le. 0.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
*/
float scasum ( int n, complex float *x, int incx ) {
// -- Reference BLAS level1 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
int i, ix;
float value;
value = 0.0;
if ( n <= 0 || incx <= 0 ) {
return value;
}
if ( incx == 1 ) {
for ( i = 0; i < n; i++ )
{
value = value + fabs ( creal ( x[i] ) )
+ fabs ( cimag ( x[i] ) );
}
}
else {
ix = 0;
for ( i = 0; i < n; i++ )
{
value = value + fabs ( creal ( x[ix] ) )
+ fabs ( cimag ( x[ix] ) );
ix = ix + incx;
}
}
return value;
}

145
src/single/scnrm2.c Normal file
View file

@ -0,0 +1,145 @@
#include <math.h>
#include <complex.h>
#include "blas_internal.h"
/*
*> \brief \b SCNRM2
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* REAL FUNCTION SCNRM2(N,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* COMPLEX X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SCNRM2 returns the euclidean norm of a vector via the function
*> name, so that
*>
*> SCNRM2 := sqrt( x**H*x )
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is COMPLEX array, dimension (N)
*> complex vector with N elements
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER, storage spacing between elements of X
*> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n
*> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n
*> If INCX = 0, x isn't a vector so there is no need to call
*> this subroutine. If you call it anyway, it will count x(1)
*> in the vector norm N times.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Edward Anderson, Lockheed Martin
*
*> \date August 2016
*
*> \ingroup single_blas_level1
*
*> \par Contributors:
* ==================
*>
*> Weslley Pereira, University of Colorado Denver, USA
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Anderson E. (2017)
*> Algorithm 978: Safe Scaling in the Level 1 BLAS
*> ACM Trans Math Softw 44:1--28
*> https://doi.org/10.1145/3061665
*>
*> Blue, James L. (1978)
*> A Portable Fortran Program to Find the Euclidean Norm of a Vector
*> ACM Trans Math Softw 4:15--23
*> https://doi.org/10.1145/355769.355771
*>
*> \endverbatim
*>
* =====================================================================
*/
float scnrm2 ( int n, complex float *x, int incx ) {
// -- Reference BLAS level1 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
int i, ix;
float scale, ssq, temp, value;
if ( n < 1 || incx < 1 ) {
value = 0.0;
} else {
scale = 0.0;
ssq = 1.0;
ix = 0;
for ( i = 0; i < n; i++ ) {
if ( creal ( x[ix] ) != 0.0 ) {
temp = fabs ( creal ( x[ix] ) );
if ( scale < temp ) {
ssq = 1.0 + ssq * pow ( scale / temp, 2 );
scale = temp;
} else {
ssq = ssq + pow ( temp / scale, 2 );
}
}
if ( cimag ( x[ix] ) != 0.0 ) {
temp = fabs ( cimag ( x[ix] ) );
if ( scale < temp )
{
ssq = 1.0 + ssq * pow ( scale / temp, 2 );
scale = temp;
}
else
{
ssq = ssq + pow ( temp / scale, 2 );
}
}
ix = ix + incx;
}
value = scale * sqrt ( ssq );
}
return value;
}

125
src/single/scopy.c Normal file
View file

@ -0,0 +1,125 @@
/*
*> \brief \b SCOPY
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SCOPY(N,SX,INCX,SY,INCY)
*
* .. Scalar Arguments ..
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* REAL SX(*),SY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SCOPY copies a vector, x, to a vector, y.
*> uses unrolled loops for increments equal to 1.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] SX
*> \verbatim
*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of SX
*> \endverbatim
*>
*> \param[out] SY
*> \verbatim
*> SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of SY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
*/
void scopy(int n, float *sx, int incx, float *sy, int incy) {
// -- Reference BLAS level1 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// .. Local Scalars ..
int i, ix, iy, m, mp1;
if (n <= 0) return;
if (incx == 1 && incy == 1) {
m = n % 7;
if (m != 0) {
for (i = 0; i < m; i++) {
sy[i] = sx[i];
}
if (n < 7) return;
}
mp1 = m + 1;
for (i = mp1; i < n; i += 7) {
sy[i] = sx[i];
sy[i + 1] = sx[i + 1];
sy[i + 2] = sx[i + 2];
sy[i + 3] = sx[i + 3];
sy[i + 4] = sx[i + 4];
sy[i + 5] = sx[i + 5];
sy[i + 6] = sx[i + 6];
}
} else {
ix = 1;
iy = 1;
if (incx < 0) ix = (-n + 1) * incx + 1;
if (incy < 0) iy = (-n + 1) * incy + 1;
for (i = 0; i < n; i++) {
sy[iy] = sx[ix];
ix += incx;
iy += incy;
}
}
// End of SCOPY
}

318
src/single/sgemv.c Normal file
View file

@ -0,0 +1,318 @@
# include "blas_internal.h"
/*
*> \brief \b SGEMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* .. Scalar Arguments ..
* REAL ALPHA,BETA
* INTEGER INCX,INCY,LDA,M,N
* CHARACTER TRANS
* ..
* .. Array Arguments ..
* REAL A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SGEMV performs one of the matrix-vector operations
*>
*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y,
*>
*> where alpha and beta are scalars, x and y are vectors and A is an
*> m by n matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS 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**T*x + beta*y.
*>
*> TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of the matrix A.
*> M must be at least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is REAL
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is REAL array, dimension ( LDA, N )
*> Before entry, the leading m by n part of the array A must
*> contain the matrix of coefficients.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> max( 1, m ).
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is REAL array, 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.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is REAL
*> On entry, BETA specifies the scalar beta. When BETA is
*> supplied as zero then Y need not be set on input.
*> \endverbatim
*>
*> \param[in,out] Y
*> \verbatim
*> Y is REAL array, 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.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
*/
void sgemv ( char trans, int m, int n, float alpha, float *a, int lda,
float *x, int incx, float beta, float *y, int incy ) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
float temp;
int i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny;
// Test the input parameters.
info = 0;
if ( ! lsame ( trans, 'N' ) &&
! lsame ( trans, 'T' ) &&
! lsame ( trans, 'C' ) ) {
info = 1;
} else if ( m < 0 ) {
info = 2;
} else if ( n < 0 ) {
info = 3;
} else if ( lda < i4_max ( 1, m ) ) {
info = 6;
} else if ( incx == 0 ) {
info = 8;
} else if ( incy == 0 ) {
info = 11;
}
if ( info != 0 ) {
xerbla ( "SGEMV", info );
return;
}
// Quick return if possible.
if ( ( m == 0 ) ||
( n == 0 ) ||
( ( alpha == 0.0 ) && ( beta == 1.0 ) ) ) {
return;
}
/*
Set LENX and LENY, the lengths of the vectors x and y, and set
up the start points in X and Y.
*/
if ( lsame ( trans, 'N' ) ) {
lenx = n;
leny = m;
} else {
lenx = m;
leny = n;
}
if ( 0 < incx ) {
kx = 0;
} else {
kx = 0 - ( lenx - 1 ) * incx;
}
if ( 0 < incy ) {
ky = 0;
} else {
ky = 0 - ( leny - 1 ) * incy;
}
/*
Start the operations. In this version the elements of A are
accessed sequentially with one pass through A.
First form y := beta*y.
*/
if ( beta != 1.0 ) {
if ( incy == 1 ) {
if ( beta == 0.0 ) {
for ( i = 0; i < leny; i++ ) {
y[i] = 0.0;
}
} else {
for ( i = 0; i < leny; i++ ) {
y[i] = beta * y[i];
}
}
} else {
iy = ky;
if ( beta == 0.0 ) {
for ( i = 0; i < leny; i++ ) {
y[iy] = 0.0;
iy = iy + incy;
}
} else {
for ( i = 0; i < leny; i++ ) {
y[iy] = beta * y[iy];
iy = iy + incy;
}
}
}
}
if ( alpha == 0.0 ) {
return;
}
// Form y := alpha*A*x + y.
if ( lsame ( trans, 'N' ) ) {
jx = kx;
if ( incy == 1 ) {
for ( j = 0; j < n; j++ ) {
if ( x[jx] != 0.0 ) {
temp = alpha * x[jx];
for ( i = 0; i < m; i++ ) {
y[i] = y[i] + temp * a[i+j*lda];
}
}
jx = jx + incx;
}
} else {
for ( j = 0; j < n; j++ ) {
if ( x[jx] != 0.0 ) {
temp = alpha * x[jx];
iy = ky;
for ( i = 0; i < m; i++ )
{
y[iy] = y[iy] + temp * a[i+j*lda];
iy = iy + incy;
}
}
jx = jx + incx;
}
}
} else {
// Form y := alpha*A'*x + y.
jy = ky;
if ( incx == 1 ) {
for ( j = 0; j < n; j++ ) {
temp = 0.0;
for ( i = 0; i < m; i++ ) {
temp = temp + a[i+j*lda] * x[i];
}
y[jy] = y[jy] + alpha * temp;
jy = jy + incy;
}
} else {
for ( j = 0; j < n; j++ ) {
temp = 0.0;
ix = kx;
for ( i = 0; i < m; i++ ) {
temp = temp + a[i+j*lda] * x[ix];
ix = ix + incx;
}
y[jy] = y[jy] + alpha * temp;
jy = jy + incy;
}
}
}
return;
}

213
src/single/sger.c Normal file
View file

@ -0,0 +1,213 @@
#include "blas_internal.h"
/*
*> \brief \b SGER
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* .. Scalar Arguments ..
* REAL ALPHA
* INTEGER INCX,INCY,LDA,M,N
* ..
* .. Array Arguments ..
* REAL A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SGER performs the rank 1 operation
*>
*> A := alpha*x*y**T + 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.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of the matrix A.
*> M must be at least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is REAL
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is REAL array, dimension at least
*> ( 1 + ( m - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the m
*> element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is REAL array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCY ) ).
*> Before entry, the incremented array Y must contain the n
*> element vector y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is REAL array, dimension ( LDA, N )
*> 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.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> max( 1, m ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_blas_level2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
*/
void sger ( int m, int n, float alpha, float *x, int incx, float *y,
int incy, float *a, int lda ) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
float temp;
int i, info, ix, j, jy, kx;
// Test the input parameters.
info = 0;
if ( m < 0 ) {
info = 1;
} else if ( n < 0 ) {
info = 2;
} else if ( incx == 0 ) {
info = 5;
} else if ( incy == 0 ) {
info = 7;
} else if ( lda < i4_max ( 1, m ) ) {
info = 9;
}
if ( info != 0 ) {
xerbla ( "SGER", info );
return;
}
// Quick return if possible.
if ( m == 0 || n == 0 || alpha == 0.0 ) {
return;
}
/*
Start the operations. In this version the elements of A are
accessed sequentially with one pass through A.
*/
if ( 0 < incy ) {
jy = 0;
} else {
jy = 0 - ( n - 1 ) * incy;
}
if ( incx == 1 ) {
for ( j = 0; j < n; j++ ) {
if ( y[jy] != 0.0 ) {
temp = alpha * y[jy];
for ( i = 0; i < m; i++ ) {
a[i+j*lda] = a[i+j*lda] + x[i] * temp;
}
}
jy = jy + incy;
}
} else {
if ( 0 < incx ) {
kx = 0;
}
else {
kx = 0 - ( m - 1 ) * incx;
}
for ( j = 0; j < n; j++ ) {
if ( y[jy] != 0.0 ) {
temp = alpha * y[jy];
ix = kx;
for ( i = 0; i < m; i++ ) {
a[i+j*lda] = a[i+j*lda] + x[ix] * temp;
ix = ix + incx;
}
}
jy = jy + incy;
}
}
return;
}

184
src/single/snrm2.c Normal file
View file

@ -0,0 +1,184 @@
#include <math.h>
#include <limits.h>
#include <stdbool.h>
/*
!> \brief \b SNRM2
!
! =========== DOCUMENTATION ===========
!
! Online html documentation available at
! http://www.netlib.org/lapack/explore-html/
!
! Definition:
! ===========
!
! REAL FUNCTION SNRM2(N,X,INCX)
!
! .. Scalar Arguments ..
! INTEGER INCX,N
! ..
! .. Array Arguments ..
! REAL X(*)
! ..
!
!
!> \par Purpose:
! =============
!>
!> \verbatim
!>
!> SNRM2 returns the euclidean norm of a vector via the function
!> name, so that
!>
!> SNRM2 := sqrt( x'*x ).
!> \endverbatim
!
! Arguments:
! ==========
!
!> \param[in] N
!> \verbatim
!> N is INTEGER
!> number of elements in input vector(s)
!> \endverbatim
!>
!> \param[in] X
!> \verbatim
!> X is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!> INCX is INTEGER, storage spacing between elements of X
!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n
!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n
!> If INCX = 0, x isn't a vector so there is no need to call
!> this subroutine. If you call it anyway, it will count x(1)
!> in the vector norm N times.
!> \endverbatim
!
! Authors:
! ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \date August 2016
!
!> \ingroup single_blas_level1
!
!> \par Contributors:
! ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!
!> \par Further Details:
! =====================
!>
!> \verbatim
!>
!> Anderson E. (2017)
!> Algorithm 978: Safe Scaling in the Level 1 BLAS
!> ACM Trans Math Softw 44:1--28
!> https://doi.org/10.1145/3061665
!>
!> Blue, James L. (1978)
!> A Portable Fortran Program to Find the Euclidean Norm of a Vector
!> ACM Trans Math Softw 4:15--23
!> https://doi.org/10.1145/355769.355771
!>
!> \endverbatim
!>
! =====================================================================
*/
float snrm2(int n, float *x, int incx) {
// -- Reference BLAS level1 routine (version 3.9.1) --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// March 2021
// .. Constants ..
const float zero = 0.0f;
const float one = 1.0f;
const float maxN = HUGE_VALF;
// .. Blue's scaling constants ..
float tsml = powf(2, ceilf((__FLT_MIN_EXP__ - 1) * 0.5f));
float tbig = powf(2, floorf((__FLT_MAX_EXP__ - __FLT_MANT_DIG__ + 1) * 0.5f));
float ssml = powf(2, -floorf((__FLT_MIN_EXP__ - __FLT_MANT_DIG__) * 0.5f));
float sbig = powf(2, -ceilf((__FLT_MAX_EXP__ + __FLT_MANT_DIG__ - 1) * 0.5f));
// .. Local Scalars ..
int i, ix;
bool notbig;
float abig, amed, asml, ax, scl, sumsq, ymax, ymin;
scl = one;
sumsq = zero;
/* Compute the sum of squares in 3 accumulators:
abig -- sums of squares scaled down to avoid overflow
asml -- sums of squares scaled up to avoid underflow
amed -- sums of squares that do not require scaling
The thresholds and multipliers are
tbig -- values bigger than this are scaled down by sbig
tsml -- values smaller than this are scaled up by ssml */
notbig = true;
asml = zero;
amed = zero;
abig = zero;
ix = 1;
if (incx < 0) {
ix = 1 - (n - 1) * incx;
}
for (i = 0; i < n; i++) {
ax = fabsf(x[ix]);
if (ax > tbig) {
abig = abig + powf(ax * sbig, 2);
notbig = 0;
} else if (ax < tsml) {
if (notbig) {
asml = asml + powf(ax * ssml, 2);
}
} else {
amed = amed + powf(ax, 2);
}
ix = ix + incx;
}
// Combine abig and amed or amed and asml if more than one accumulator was used.
if (abig > zero) {
// Combine abig and amed if abig > 0.
if ((amed > zero) || (amed > maxN) || isnan(amed)) {
abig = abig + amed * sbig * sbig;
}
scl = one / sbig;
sumsq = abig;
} else if (asml > zero) {
// Combine amed and asml if asml > 0.
if ((amed > zero) || (amed > maxN) || isnan(amed)) {
amed = sqrtf(amed);
asml = sqrtf(asml) / ssml;
if (asml > amed) {
ymin = amed;
ymax = asml;
} else {
ymin = asml;
ymax = amed;
}
scl = one;
sumsq = powf(ymax, 2) * (one + powf(ymin / ymax, 2));
} else {
scl = one / ssml;
sumsq = asml;
}
} else {
// Otherwise all values are mid-range
scl = one;
sumsq = amed;
}
return scl * sqrtf(sumsq);
}

180
src/single/srotg.c Normal file
View file

@ -0,0 +1,180 @@
#include <math.h>
/*
!> \brief \b SROTG
!
! =========== DOCUMENTATION ===========
!
! Online html documentation available at
! http://www.netlib.org/lapack/explore-html/
!
! Definition:
! ===========
!
! SROTG constructs a plane rotation
! [ c s ] [ a ] = [ r ]
! [ -s c ] [ b ] [ 0 ]
! satisfying c**2 + s**2 = 1.
!
!> \par Purpose:
! =============
!>
!> \verbatim
!>
!> The computation uses the formulas
!> sigma = sgn(a) if |a| > |b|
!> = sgn(b) if |b| >= |a|
!> r = sigma*sqrt( a**2 + b**2 )
!> c = 1; s = 0 if r = 0
!> c = a/r; s = b/r if r != 0
!> The subroutine also computes
!> z = s if |a| > |b|,
!> = 1/c if |b| >= |a| and c != 0
!> = 1 if c = 0
!> This allows c and s to be reconstructed from z as follows:
!> If z = 1, set c = 0, s = 1.
!> If |z| < 1, set c = sqrt(1 - z**2) and s = z.
!> If |z| > 1, set c = 1/z and s = sqrt( 1 - c**2).
!>
!> \endverbatim
!
! Arguments:
! ==========
!
!> \param[in,out] A
!> \verbatim
!> A is REAL
!> On entry, the scalar a.
!> On exit, the scalar r.
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!> B is REAL
!> On entry, the scalar b.
!> On exit, the scalar z.
!> \endverbatim
!>
!> \param[out] C
!> \verbatim
!> C is REAL
!> The scalar c.
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!> S is REAL
!> The scalar s.
!> \endverbatim
!
! Authors:
! ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \par Contributors:
! ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!
!> \ingroup single_blas_level1
!
!> \par Further Details:
! =====================
!>
!> \verbatim
!>
!> Anderson E. (2017)
!> Algorithm 978: Safe Scaling in the Level 1 BLAS
!> ACM Trans Math Softw 44:1--28
!> https://doi.org/10.1145/3061665
!>
!> \endverbatim
!
! =====================================================================
*/
void srotg(float *a, float *b, float *c, float *s) {
// -- Reference BLAS level1 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// .. Scalar Arguments ..
double r;
double roe;
double scale;
double z;
if (fabs(*b) < fabs(*a)) {
roe = *a;
} else {
roe = *b;
}
scale = fabs(*a) + fabs(*b);
if (scale == 0.0) {
*c = 1.0;
*s = 0.0;
r = 0.0;
} else {
r = scale * sqrt((*a / scale) * (*a / scale)
+ (*b / scale) * (*b / scale));
if (roe < 0.0) {
r = - r;
}
*c = *a / r;
*s = *b / r;
}
if (0.0 < fabs (*c) && fabs (*c) <= *s) {
z = 1.0 / *c;
} else {
z = *s;
}
*a = r;
*b = z;
/*
float safmin, safmax, anorm, bnorm, scl, sigma, r, z;
safmax = (double)0.0;
safmax = (double)0.0;
anorm = fabs(*a);
bnorm = fabs(*b);
if (bnorm == 0.0) {
c = 1.0;
s = 0.0;
b = 0.0;
} else if (anorm == 0.0) {
c = 0.0;
s = 1.0;
a = b;
b = 1;
} else {
scl = fmin(safmax, fmax(safmax, anorm, bnorm));
if (anorm > bnorm) {
sigma = a/anorm;
} else {
sigma = b/bnorm;
}
r = sigma*scl*sqrt((a/scl)*(a/scl) + (b/scl)*(b/scl));
c = a/r;
s = b/r;
if (anorm > bnorm) {
z = s;
} else if (c /= 0.0) {
z = 1.0/c;
} else {
z = 1.0;
}
a = r;
b = z;
}
*/
return;
}

123
src/single/sscal.c Normal file
View file

@ -0,0 +1,123 @@
/*
*> \brief \b SSCAL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SSCAL(N,SA,SX,INCX)
*
* .. Scalar Arguments ..
* REAL SA
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* REAL SX(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SSCAL scales a vector by a constant.
*> uses unrolled loops for increment equal to 1.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] SA
*> \verbatim
*> SA is REAL
*> On entry, SA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in,out] SX
*> \verbatim
*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of SX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_blas_level1
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 3/93 to return if incx .le. 0.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
*/
void sscal(int n, float sa, float sx[], int incx) {
// -- Reference BLAS level1 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
int i, m, mp1, nincx;
float one = 1.0E+0;
if (n <= 0 || incx <= 0 || sa == one) return;
if (incx == 1) {
// code for increment equal to 1
// clean-up loop
m = n % 5;
if (m != 0) {
for (i = 0; i < m; i++) {
sx[i] = sa * sx[i];
}
if (n < 5) return;
}
mp1 = m + 1;
for (i = mp1; i < n; i += 5) {
sx[i] = sa * sx[i];
sx[i + 1] = sa * sx[i + 1];
sx[i + 2] = sa * sx[i + 2];
sx[i + 3] = sa * sx[i + 3];
sx[i + 4] = sa * sx[i + 4];
}
} else {
// code for increment not equal to 1
nincx = n * incx;
for (i = 0; i < nincx; i += incx) {
sx[i] = sa * sx[i];
}
}
// End of SSCAL
}

187
src/ctrmv.c → src/single/strmv.c
View file

@ -1,10 +1,7 @@
#include <complex.h>
#include <stdbool.h>
#include "blas.h"
#include "blas_internal.h"
/*
*> \brief \b CTRMV
*> \brief \b STRMV
*
* =========== DOCUMENTATION ===========
*
@ -14,14 +11,14 @@
* Definition:
* ===========
*
* SUBROUTINE CTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
* SUBROUTINE STRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,LDA,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* COMPLEX A(LDA,*),X(*)
* REAL A(LDA,*),X(*)
* ..
*
*
@ -30,9 +27,9 @@
*>
*> \verbatim
*>
*> CTRMV performs one of the matrix-vector operations
*> STRMV performs one of the matrix-vector operations
*>
*> x := A*x, or x := A**T*x, or x := A**H*x,
*> x := A*x, or x := A**T*x,
*>
*> where x is an n element vector and A is an n by n unit, or non-unit,
*> upper or lower triangular matrix.
@ -62,7 +59,7 @@
*>
*> TRANS = 'T' or 't' x := A**T*x.
*>
*> TRANS = 'C' or 'c' x := A**H*x.
*> TRANS = 'C' or 'c' x := A**T*x.
*> \endverbatim
*>
*> \param[in] DIAG
@ -86,7 +83,7 @@
*>
*> \param[in] A
*> \verbatim
*> A is COMPLEX array, dimension ( LDA, N ).
*> A is REAL array, dimension ( LDA, N )
*> 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
@ -109,7 +106,7 @@
*>
*> \param[in,out] X
*> \verbatim
*> X is COMPLEX array, dimension at least
*> X is REAL array, 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
@ -131,7 +128,7 @@
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_blas_level2
*> \ingroup single_blas_level2
*
*> \par Further Details:
* =====================
@ -150,7 +147,8 @@
*>
* =====================================================================
*/
void ctrmv(char uplo, char trans, char diag, int n, complex float a[], int lda, complex float x[], int incx) {
void strmv(char uplo, char trans, char diag, int n, float *a, int lda,
float *x, int incx) {
// -- Reference BLAS level2 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
@ -158,67 +156,62 @@ void ctrmv(char uplo, char trans, char diag, int n, complex float a[], int lda,
// =====================================================================
// .. Parameters ..
complex float zero = (0.0E+0,0.0E+0*I);
// ..
// .. Local Scalars ..
complex float temp;
int i,info,ix,j,jx,kx;
bool noconj,nounit;
int i, info, ix, j, jx, kx, nounit;
float temp;
// Test the input parameters.
// Test the input parameters.
//
info = 0;
if ( !lsame( uplo, 'U' ) && !lsame( uplo, 'L' ) ) {
if ( ! lsame ( uplo, 'U' ) && ! lsame ( uplo, 'L' ) ) {
info = 1;
} else if ( !lsame( trans, 'N' ) && !lsame( trans, 'T' ) &&
!lsame( trans, 'C' ) ) {
} else if ( ! lsame ( trans, 'N' ) && ! lsame ( trans, 'T' ) &&
! lsame ( trans, 'C' ) ) {
info = 2;
} else if ( !lsame( diag, 'U' ) && !lsame( diag, 'N' ) ) {
} else if ( ! lsame ( diag, 'U' ) && ! lsame ( diag, 'N' ) ) {
info = 3;
} else if (n < 0) {
} else if ( n < 0 ) {
info = 4;
} else if ( lda < i4_max( 1, n ) ) {
} else if ( lda < i4_max ( 1, n ) ) {
info = 6;
} else if ( incx == 0 ) {
info = 8;
}
if ( info != 0 ) {
xerbla('CTRMV', info);
xerbla ( "STRMV", info );
return;
}
//
// Quick return if possible.
//
// Quick return if possible.
if ( n == 0 ) {
return;
}
//
noconj = lsame( trans, 'T' );
nounit = lsame( diag, 'N' );
// Set up the start point in X if the increment is not unity. This
// will be ( N - 1 )*INCX too small for descending loops.
nounit = lsame ( diag, 'N' );
/*
Set up the start point in X if the increment is not unity. This
will be ( N - 1 ) * INCX too small for descending loops.
*/
if ( incx <= 0 ) {
kx = 0 - ( n-1 ) * incx;
kx = 0 - ( n - 1 ) * incx;
} else if ( incx != 1 ) {
kx = 0;
}
// Start the operations. In this version the elements of A are
// accessed sequentially with one pass through A.
if ( lsame( trans, 'N' ) ) {
/*
Start the operations. In this version the elements of A are
accessed sequentially with one pass through A.
*/
if ( lsame ( trans, 'N' ) ) {
// Form x := A*x.
if ( lsame(uplo,'U') ) {
if (incx == 1) {
if ( lsame ( uplo, 'U' ) ) {
if ( incx == 1 ) {
for ( j = 0; j < n; j++ ) {
if ( x[j] != zero ) {
if ( x[j] != 0.0 ) {
temp = x[j];
for ( i = 0; i < j - 1; i++ ) {
for ( i = 0; i < j; i++ ) {
x[i] = x[i] + temp * a[i+j*lda];
}
if ( nounit ) {
@ -229,7 +222,7 @@ void ctrmv(char uplo, char trans, char diag, int n, complex float a[], int lda,
} else {
jx = kx;
for ( j = 0; j < n; j++ ) {
if (x[jx] != zero) {
if ( x[jx] != 0.0 ) {
temp = x[jx];
ix = kx;
for ( i = 0; i < j; i++ ) {
@ -246,7 +239,7 @@ void ctrmv(char uplo, char trans, char diag, int n, complex float a[], int lda,
} else {
if ( incx == 1 ) {
for ( j = n - 1; 0 <= j; j-- ) {
if ( x[j] != zero) {
if ( x[j] != 0.0 ) {
temp = x[j];
for ( i = n - 1; j < i; i-- ) {
x[i] = x[i] + temp * a[i+j*lda];
@ -260,7 +253,7 @@ void ctrmv(char uplo, char trans, char diag, int n, complex float a[], int lda,
kx = kx + ( n - 1 ) * incx;
jx = kx;
for ( j = n - 1; 0 <= j; j-- ) {
if (x[jx] != zero) {
if ( x[jx] != 0.0 ) {
temp = x[jx];
ix = kx;
for ( i = n - 1; j < i; i-- ) {
@ -276,51 +269,30 @@ void ctrmv(char uplo, char trans, char diag, int n, complex float a[], int lda,
}
}
} else {
// Form x := A**T*x or x := A**H*x.
if ( lsame(uplo,'U') ) {
// Form x := A'*x.
if ( lsame ( uplo, 'U' ) ) {
if ( incx == 1 ) {
for ( j = n - 1; 0 <= j; j-- ) {
temp = x[j];
if ( noconj ) {
if ( nounit ) {
temp = temp * a[j+j*lda];
}
for ( i = j - 1; 0 <= i; i-- ) {
temp = temp + a[i+j*lda] * x[i];
}
} else {
if (nounit) {
temp = temp * (~a[j+j*lda]);
}
for ( i = j-1; 0 <= i; i-- ) {
temp = temp + (~a[i+j*lda])*x[i];
}
if ( nounit ) {
temp = temp * a[j+j*lda];
}
for ( i = j - 1; 0 <= i; i-- ) {
temp = temp + a[i+j*lda] * x[i];
}
x[j] = temp;
}
} else {
jx = kx + ( n-1 ) * incx;
jx = kx + ( n - 1 ) * incx;
for ( j = n - 1; 0 <= j; j-- ) {
temp = x[jx];
ix = jx;
if ( noconj ) {
if ( nounit ) {
temp = temp * a[j+j*lda];
}
for ( i = j - 1; 0 <= i; i-- ) {
ix = ix - incx;
temp = temp + a[i+j*lda] * x[ix];
}
} else {
if (nounit) {
temp = temp * (~a[j+j*lda]);
}
for ( i = j-1; 0 <= i; i-- ) {
ix = ix - incx;
temp = temp + (~a[i+j*lda]) * x[ix];
}
if ( nounit ) {
temp = temp * a[j+j*lda];
}
for ( i = j - 1; 0 <= i; i-- ) {
ix = ix - incx;
temp = temp + a[i+j*lda] * x[ix];
}
x[jx] = temp;
jx = jx - incx;
@ -330,18 +302,11 @@ void ctrmv(char uplo, char trans, char diag, int n, complex float a[], int lda,
if ( incx == 1 ) {
for ( j = 0; j < n; j++ ) {
temp = x[j];
if ( noconj ) {
if (nounit) {
temp = temp*a[j+j*lda];
}
for ( i = j + 1; i < n; i++ ) {
temp = temp + a[i+j*lda] * x[i];
}
} else {
if (nounit) temp = temp * (~a[j+j*lda]);
for ( i = j + 1; i < n; i++ ) {
temp = temp + (~a[i+j*lda]) * x[i];
}
if ( nounit ) {
temp = temp * a[j+j*lda];
}
for ( i = j + 1; i < n; i++ ) {
temp = temp + a[i+j*lda] * x[i];
}
x[j] = temp;
}
@ -350,20 +315,12 @@ void ctrmv(char uplo, char trans, char diag, int n, complex float a[], int lda,
for ( j = 0; j < n; j++ ) {
temp = x[jx];
ix = jx;
if ( noconj ) {
if ( nounit ) {
temp = temp*a[j+j*lda];
}
for ( i = j + 1; i < n; i++ ) {
ix = ix + incx;
temp = temp + a[i+j*lda] * x[ix];
}
} else {
if (nounit) temp = temp * (~a[j+j*lda]);
for ( i = j + 1; i < n; i++ ) {
ix = ix + incx;
temp = temp + (~a[i+j*lda]) * x[ix];
}
if ( nounit ) {
temp = temp * a[j+j*lda];
}
for ( i = j + 1; i < n; i++ ) {
ix = ix + incx;
temp = temp + a[i+j*lda] * x[ix];
}
x[jx] = temp;
jx = jx + incx;
@ -374,6 +331,6 @@ void ctrmv(char uplo, char trans, char diag, int n, complex float a[], int lda,
return;
// End of CTRMV .
// End of STRMV
}
}

442
src/single/strsm.c Normal file
View file

@ -0,0 +1,442 @@
#include <stdbool.h>
#include "blas_internal.h"
/*
*> \brief \b STRSM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*
* .. Scalar Arguments ..
* REAL ALPHA
* INTEGER LDA,LDB,M,N
* CHARACTER DIAG,SIDE,TRANSA,UPLO
* ..
* .. Array Arguments ..
* REAL A(LDA,*),B(LDB,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> STRSM solves one of the matrix equations
*>
*> op( A )*X = alpha*B, or X*op( A ) = alpha*B,
*>
*> where alpha is a scalar, X and B are m by n matrices, A is a unit, or
*> non-unit, upper or lower triangular matrix and op( A ) is one of
*>
*> op( A ) = A or op( A ) = A**T.
*>
*> The matrix X is overwritten on B.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> On entry, SIDE specifies whether op( A ) appears on the left
*> or right of X as follows:
*>
*> SIDE = 'L' or 'l' op( A )*X = alpha*B.
*>
*> SIDE = 'R' or 'r' X*op( A ) = alpha*B.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the matrix A 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.
*> \endverbatim
*>
*> \param[in] TRANSA
*> \verbatim
*> TRANSA is CHARACTER*1
*> On entry, TRANSA 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**T.
*>
*> TRANSA = 'C' or 'c' op( A ) = A**T.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> On entry, DIAG 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.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of B. M must be at
*> least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of B. N must be
*> at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is REAL
*> On entry, ALPHA specifies the scalar alpha. When alpha is
*> zero then A is not referenced and B need not be set before
*> entry.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is REAL array, dimension ( LDA, k ),
*> where k is m when SIDE = 'L' or 'l'
*> and k is n when SIDE = 'R' or 'r'.
*> Before entry with UPLO = 'U' or 'u', the leading k by k
*> 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 k by k
*> 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.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA 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 ), when SIDE = 'R' or 'r'
*> then LDA must be at least max( 1, n ).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is REAL array, dimension ( LDB, N )
*> Before entry, the leading m by n part of the array B must
*> contain the right-hand side matrix B, and on exit is
*> overwritten by the solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> On entry, LDB specifies the first dimension of B as declared
*> in the calling (sub) program. LDB must be at least
*> max( 1, m ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_blas_level3
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 3 Blas routine.
*>
*>
*> -- Written on 8-February-1989.
*> Jack Dongarra, Argonne National Laboratory.
*> Iain Duff, AERE Harwell.
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
*> Sven Hammarling, Numerical Algorithms Group Ltd.
*> \endverbatim
*>
* =====================================================================
*/
void strsm ( char side, char uplo, char transa, char diag, int m, int n,
float alpha, float *a, int lda, float *b, int ldb ) {
// -- Reference BLAS level3 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
float temp;
int i, info, j, k, nrowa;
bool lside, nounit, upper;
// Test the input parameters.
lside = lsame ( side, 'L' );
if ( lside ) {
nrowa = m;
}
else {
nrowa = n;
}
nounit = lsame ( diag, 'N' );
upper = lsame ( uplo, 'U' );
info = 0;
if ( ( ! lside ) && ( ! lsame ( side, 'R' ) ) ) {
info = 1;
}
else if ( ( ! upper ) && ( ! lsame ( uplo, 'L' ) ) ) {
info = 2;
}
else if ( ( ! lsame ( transa, 'N' ) ) &&
( ! lsame ( transa, 'T' ) ) &&
( ! lsame ( transa, 'C' ) ) ) {
info = 3;
}
else if ( ( ! lsame ( diag, 'U' ) ) && ( ! lsame ( diag, 'N' ) ) ) {
info = 4;
}
else if ( m < 0 ) {
info = 5;
}
else if ( n < 0 ) {
info = 6;
}
else if ( lda < i4_max ( 1, nrowa ) ) {
info = 9;
}
else if ( ldb < i4_max ( 1, m ) ) {
info = 11;
}
if ( info != 0 ) {
xerbla ( "STRSM", info );
return;
}
// Quick return if possible.
if ( n == 0 ) {
return;
}
// and when alpha is 0.0.
if ( alpha == 0.0 ) {
for ( j = 0; j < n; j++ ) {
for ( i = 0; i < m; i++ ) {
b[i+j*ldb] = 0.0;
}
}
return;
}
// Start the operations.
if ( lside ) {
// Form B := alpha*inv( a )*B.
if ( lsame ( transa, 'N' ) ) {
if ( upper ) {
for ( j = 0; j < n; j++ ) {
if ( alpha != 1.0 ) {
for ( i = 0; i < m; i++ ) {
b[i+j*ldb] = alpha * b[i+j*ldb];
}
}
for ( k = m - 1; 0 <= k; k-- ) {
if ( b[k+j*ldb] != 0.0 ) {
if ( nounit ) {
b[k+j*ldb] = b[k+j*ldb] / a[k+k*lda];
}
for ( i = 0; i < k; i++ ) {
b[i+j*ldb] = b[i+j*ldb] - b[k+j*ldb] * a[i+k*lda];
}
}
}
}
} else {
for ( j = 0; j < n; j++ ) {
if ( alpha != 1.0 ) {
for ( i = 0; i < m; i++ ) {
b[i+j*ldb] = alpha * b[i+j*ldb];
}
}
for ( k = 0; k < m; k++ ) {
if ( b[k+j*ldb] != 0.0 ) {
if ( nounit ) {
b[k+j*ldb] = b[k+j*ldb] / a[k+k*lda];
}
for ( i = k + 1; i < m; i++ ) {
b[i+j*ldb] = b[i+j*ldb] - b[k+j*ldb] * a[i+k*lda];
}
}
}
}
}
} else {
// Form B := alpha*inv( A' )*B.
if ( upper ) {
for ( j = 0; j < n; j++ ) {
for ( i = 0; i < m; i++ ) {
temp = alpha * b[i+j*ldb];
for ( k = 0; k < i; k++ ) {
temp = temp - a[k+i*lda] * b[k+j*ldb];
}
if ( nounit ) {
temp = temp / a[i+i*lda];
}
b[i+j*ldb] = temp;
}
}
} else {
for ( j = 0; j < n; j++ ) {
for ( i = m - 1; 0 <= i; i-- ) {
temp = alpha * b[i+j*ldb];
for ( k = i + 1; k < m; k++ ) {
temp = temp - a[k+i*lda] * b[k+j*ldb];
}
if ( nounit ) {
temp = temp / a[i+i*lda];
}
b[i+j*ldb] = temp;
}
}
}
}
} else {
// Form B := alpha*B*inv( A ).
if ( lsame ( transa, 'N' ) ) {
if ( upper ) {
for ( j = 0; j < n; j++ ) {
if ( alpha != 1.0 ) {
for ( i = 0; i < m; i++ ) {
b[i+j*ldb] = alpha * b[i+j*ldb];
}
}
for ( k = 0; k < j; k++ ) {
if ( a[k+j*lda] != 0.0 ) {
for ( i = 0; i < m; i++ ) {
b[i+j*ldb] = b[i+j*ldb] - a[k+j*lda] * b[i+k*ldb];
}
}
}
if ( nounit ) {
temp = 1.0 / a[j+j*lda];
for ( i = 0; i < m; i++ ) {
b[i+j*ldb] = temp * b[i+j*ldb];
}
}
}
} else {
for ( j = n - 1; 0 <= j; j-- ) {
if ( alpha != 1.0 ) {
for ( i = 0; i < m; i++ ) {
b[i+j*ldb] = alpha * b[i+j*ldb];
}
}
for ( k = j + 1; k < n; k++ ) {
if ( a[k+j*lda] != 0.0 ) {
for ( i = 0; i < m; i++ ) {
b[i+j*ldb] = b[i+j*ldb] - a[k+j*lda] * b[i+k*ldb];
}
}
}
if ( nounit ) {
temp = 1.0 / a[j+j*lda];
for ( i = 0; i < m; i++ ) {
b[i+j*ldb] = temp * b[i+j*ldb];
}
}
}
}
} else {
// Form B := alpha*B*inv( A' ).
if ( upper ) {
for ( k = n - 1; 0 <= k; k-- ) {
if ( nounit ) {
temp = 1.0 / a[k+k*lda];
for ( i = 0; i < m; i++ ) {
b[i+k*ldb] = temp * b[i+k*ldb];
}
}
for ( j = 0; j < k; j++ ) {
if ( a[j+k*lda] != 0.0 ) {
temp = a[j+k*lda];
for ( i = 0; i < m; i++ ) {
b[i+j*ldb] = b[i+j*ldb] - temp * b[i+k*ldb];
}
}
}
if ( alpha != 1.0 ) {
for ( i = 0; i < m; i++ ) {
b[i+k*ldb] = alpha * b[i+k*ldb];
}
}
}
}
else {
for ( k = 0; k < n; k++ ) {
if ( nounit ) {
temp = 1.0 / a[k+k*lda];
for ( i = 0; i < m; i++ ) {
b[i+k*ldb] = temp * b[i+k*ldb];
}
}
for ( j = k + 1; j < n; j++ ) {
if ( a[j+k*lda] != 0.0 ) {
temp = a[j+k*lda];
for ( i = 0; i < m; i++ ) {
b[i+j*ldb] = b[i+j*ldb] - temp * b[i+k*ldb];
}
}
}
if ( alpha != 1.0 ) {
for ( i = 0; i < m; i++ ) {
b[i+k*ldb] = alpha * b[i+k*ldb];
}
}
}
}
}
}
return;
// End of STRSM
}

9
src/xerbla.c
View file

@ -1,6 +1,5 @@
#include <stdio.h>
#include "errquit.h"
#include <stdlib.h>
/*
*> \brief \b XERBLA
@ -62,16 +61,16 @@
*
* =====================================================================
*/
void xerbla( char *srname, int info ) {
void xerbla(char *srname, int info) {
// -- Reference BLAS level1 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
printf("xerbla:double: lapack error\n");
printf(" ** On entry to %s parameter number %d had an illegal value", srname, info);
printf(" ** On entry to %s parameter number %d had an illegal value\n", srname, info);
exit(1);
// End of XERBLA
}
}

68
src/xerbla_array.c
View file

@ -1,3 +1,8 @@
#include <stdlib.h>
#include "blas_internal.h"
/*
*> \brief \b XERBLA_ARRAY
*
* =========== DOCUMENTATION ===========
@ -76,44 +81,29 @@
*> \ingroup aux_blas
*
* =====================================================================
SUBROUTINE XERBLA_ARRAY(SRNAME_ARRAY, SRNAME_LEN, INFO)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER SRNAME_LEN, INFO
* ..
* .. Array Arguments ..
CHARACTER(1) SRNAME_ARRAY(SRNAME_LEN)
* ..
*
* =====================================================================
*
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. Local Arrays ..
CHARACTER*32 SRNAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN, LEN
* ..
* .. External Functions ..
EXTERNAL XERBLA
* ..
* .. Executable Statements ..
SRNAME = ' '
DO I = 1, MIN( SRNAME_LEN, LEN( SRNAME ) )
SRNAME( I:I ) = SRNAME_ARRAY( I )
END DO
*/
void xerbla_array(char *srname_array, int srname_len, int info) {
CALL XERBLA( SRNAME, INFO )
// -- Reference BLAS level1 routine --
// -- Reference BLAS is a software package provided by Univ. of Tennessee, --
// -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
// =====================================================================
// .. Local Scalars ..
int i;
// .. Local Arrays ..
char srname[32];
// .. Executable Statements ..
for (i = 0; i < srname_len && i < 32; i++) {
srname[i] = srname_array[i];
}
xerbla(srname, info);
// End of XERBLA_ARRAY
}
RETURN
*
* End of XERBLA_ARRAY
*
END