diff --git a/.gitignore b/.gitignore index 1f40305..5654280 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,10 @@ -.vscode/* -build/* +.vscode +bin +build +/include +lib +*.o +*.obj +*.so +*.a +*.la \ No newline at end of file diff --git a/CMakeLists.txt b/CMakeLists.txt index dd80fe5..1a2bb25 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -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: diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index cac34d3..7e3ebc8 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -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}) \ No newline at end of file +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) diff --git a/src/abssq.c b/src/abssq.c new file mode 100644 index 0000000..6911bfd --- /dev/null +++ b/src/abssq.c @@ -0,0 +1,11 @@ +#include +#include + +/* + +DOCUMENTATION HERE + +*/ +float abssq(complex float t) { + return powf(creal(t), 2) + powf(cimag(t), 2); +} diff --git a/src/blas_internal.h b/src/blas_internal.h new file mode 100644 index 0000000..35f4f99 --- /dev/null +++ b/src/blas_internal.h @@ -0,0 +1,21 @@ +#ifndef _BLAS_INTERNAL_H +#define _BLAS_INTERNAL_H + + +// #include "errquit.h" +#include +#include + + 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 diff --git a/src/cgbmv.c b/src/cgbmv.c deleted file mode 100644 index 42a1da0..0000000 --- a/src/cgbmv.c +++ /dev/null @@ -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 diff --git a/src/chemv.c b/src/chemv.c deleted file mode 100644 index 288ab14..0000000 --- a/src/chemv.c +++ /dev/null @@ -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 diff --git a/src/cher.c b/src/cher.c deleted file mode 100644 index 2695a7e..0000000 --- a/src/cher.c +++ /dev/null @@ -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 diff --git a/src/cher2.c b/src/cher2.c deleted file mode 100644 index 68976b4..0000000 --- a/src/cher2.c +++ /dev/null @@ -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 diff --git a/src/cher2k.c b/src/cher2k.c deleted file mode 100644 index a779087..0000000 --- a/src/cher2k.c +++ /dev/null @@ -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 diff --git a/src/cherk.c b/src/cherk.c deleted file mode 100644 index 4b229c2..0000000 --- a/src/cherk.c +++ /dev/null @@ -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 diff --git a/src/chpmv.c b/src/chpmv.c deleted file mode 100644 index 459a9ba..0000000 --- a/src/chpmv.c +++ /dev/null @@ -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 diff --git a/src/chpr.c b/src/chpr.c deleted file mode 100644 index 62a946f..0000000 --- a/src/chpr.c +++ /dev/null @@ -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 diff --git a/src/chpr2.c b/src/chpr2.c deleted file mode 100644 index cb07168..0000000 --- a/src/chpr2.c +++ /dev/null @@ -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 diff --git a/src/crotg.c b/src/crotg.c deleted file mode 100644 index 8704196..0000000 --- a/src/crotg.c +++ /dev/null @@ -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 diff --git a/src/csyr2k.c b/src/csyr2k.c deleted file mode 100644 index 0975189..0000000 --- a/src/csyr2k.c +++ /dev/null @@ -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 diff --git a/src/csyrk.c b/src/csyrk.c deleted file mode 100644 index 97bde05..0000000 --- a/src/csyrk.c +++ /dev/null @@ -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 diff --git a/src/ctbmv.c b/src/ctbmv.c deleted file mode 100644 index c0be8f4..0000000 --- a/src/ctbmv.c +++ /dev/null @@ -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 diff --git a/src/ctbsv.c b/src/ctbsv.c deleted file mode 100644 index b3600e4..0000000 --- a/src/ctbsv.c +++ /dev/null @@ -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 diff --git a/src/ctpmv.c b/src/ctpmv.c deleted file mode 100644 index b4651a2..0000000 --- a/src/ctpmv.c +++ /dev/null @@ -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 diff --git a/src/ctpsv.c b/src/ctpsv.c deleted file mode 100644 index d306cc2..0000000 --- a/src/ctpsv.c +++ /dev/null @@ -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 diff --git a/src/ctrmm.c b/src/ctrmm.c deleted file mode 100644 index 2597372..0000000 --- a/src/ctrmm.c +++ /dev/null @@ -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 diff --git a/src/ctrsm.c b/src/ctrsm.c deleted file mode 100644 index 7da6cfe..0000000 --- a/src/ctrsm.c +++ /dev/null @@ -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 diff --git a/src/ctrsv.c b/src/ctrsv.c deleted file mode 100644 index de0640e..0000000 --- a/src/ctrsv.c +++ /dev/null @@ -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 diff --git a/src/lsame.c b/src/lsame.c index 98a3b4e..a27f562 100644 --- a/src/lsame.c +++ b/src/lsame.c @@ -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 - -} \ No newline at end of file + return inta == intb; +} diff --git a/src/caxpy.c b/src/single/caxpy.c similarity index 82% rename from src/caxpy.c rename to src/single/caxpy.c index b2b2397..8ebec7c 100644 --- a/src/caxpy.c +++ b/src/single/caxpy.c @@ -1,6 +1,6 @@ #include -#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 diff --git a/src/ccopy.c b/src/single/ccopy.c similarity index 67% rename from src/ccopy.c rename to src/single/ccopy.c index 369f366..41b2186 100644 --- a/src/ccopy.c +++ b/src/single/ccopy.c @@ -1,7 +1,5 @@ #include -#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 +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; +} +*/ diff --git a/src/cdotc.c b/src/single/cdotc.c similarity index 73% rename from src/cdotc.c rename to src/single/cdotc.c index afc2274..b7d82fc 100644 --- a/src/cdotc.c +++ b/src/single/cdotc.c @@ -1,7 +1,5 @@ #include -#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 diff --git a/src/cdotu.c b/src/single/cdotu.c similarity index 74% rename from src/cdotu.c rename to src/single/cdotu.c index 35ff563..6459fda 100644 --- a/src/cdotu.c +++ b/src/single/cdotu.c @@ -1,7 +1,5 @@ #include -#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 diff --git a/src/single/cgbmv.c b/src/single/cgbmv.c new file mode 100644 index 0000000..c458876 --- /dev/null +++ b/src/single/cgbmv.c @@ -0,0 +1,356 @@ +#include +#include +#include + +#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; + } + } + } +} diff --git a/src/cgemm.c b/src/single/cgemm.c similarity index 53% rename from src/cgemm.c rename to src/single/cgemm.c index 42e31c4..a8b99d7 100644 --- a/src/cgemm.c +++ b/src/single/cgemm.c @@ -1,9 +1,8 @@ -#include -#include +#include #include #include -#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 . -} \ No newline at end of file +} diff --git a/src/cgemv.c b/src/single/cgemv.c similarity index 68% rename from src/cgemv.c rename to src/single/cgemv.c index 5dc0370..dbbe4a5 100644 --- a/src/cgemv.c +++ b/src/single/cgemv.c @@ -1,7 +1,8 @@ +#include #include #include -#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 . -} \ No newline at end of file +} diff --git a/src/cgerc.c b/src/single/cgerc.c similarity index 80% rename from src/cgerc.c rename to src/single/cgerc.c index e17a133..a81f947 100644 --- a/src/cgerc.c +++ b/src/single/cgerc.c @@ -1,6 +1,7 @@ +#include #include -#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 . - -} \ No newline at end of file +} diff --git a/src/cgeru.c b/src/single/cgeru.c similarity index 57% rename from src/cgeru.c rename to src/single/cgeru.c index 5ff8f94..f134692 100644 --- a/src/cgeru.c +++ b/src/single/cgeru.c @@ -1,3 +1,8 @@ +#include + +#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 + +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 + +} diff --git a/src/chbmv.c b/src/single/chbmv.c similarity index 51% rename from src/chbmv.c rename to src/single/chbmv.c index bddab93..27ab9af 100644 --- a/src/chbmv.c +++ b/src/single/chbmv.c @@ -1,3 +1,9 @@ +#include +#include + +#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 + +} diff --git a/src/chemm.c b/src/single/chemm.c similarity index 55% rename from src/chemm.c rename to src/single/chemm.c index 5d66dda..e98c3fd 100644 --- a/src/chemm.c +++ b/src/single/chemm.c @@ -1,3 +1,10 @@ +#include +#include +#include + +#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 + +} diff --git a/src/single/chemv.c b/src/single/chemv.c new file mode 100644 index 0000000..7d4fc99 --- /dev/null +++ b/src/single/chemv.c @@ -0,0 +1,302 @@ +#include +#include + +#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; + } + } + } +} diff --git a/src/single/cher.c b/src/single/cher.c new file mode 100644 index 0000000..c577624 --- /dev/null +++ b/src/single/cher.c @@ -0,0 +1,248 @@ +#include + +#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 + +} diff --git a/src/single/cher2.c b/src/single/cher2.c new file mode 100644 index 0000000..583b127 --- /dev/null +++ b/src/single/cher2.c @@ -0,0 +1,279 @@ +#include +#include + +#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; + } + } + } +} diff --git a/src/single/cher2k.c b/src/single/cher2k.c new file mode 100644 index 0000000..b79674a --- /dev/null +++ b/src/single/cher2k.c @@ -0,0 +1,388 @@ +#include +#include + +#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 + +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 + +} diff --git a/src/single/cherk.c b/src/single/cherk.c new file mode 100644 index 0000000..1599f73 --- /dev/null +++ b/src/single/cherk.c @@ -0,0 +1,369 @@ +#include +#include +#include +#include + +#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 + +} diff --git a/src/single/chpmv.c b/src/single/chpmv.c new file mode 100644 index 0000000..6ea32b1 --- /dev/null +++ b/src/single/chpmv.c @@ -0,0 +1,307 @@ +#include + +#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 + +} diff --git a/src/single/chpr.c b/src/single/chpr.c new file mode 100644 index 0000000..214fa75 --- /dev/null +++ b/src/single/chpr.c @@ -0,0 +1,250 @@ +#include + +#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 + +} diff --git a/src/single/chpr2.c b/src/single/chpr2.c new file mode 100644 index 0000000..588c856 --- /dev/null +++ b/src/single/chpr2.c @@ -0,0 +1,283 @@ +#include + +#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 + +} diff --git a/src/single/crotg.c b/src/single/crotg.c new file mode 100644 index 0000000..3fb4e0b --- /dev/null +++ b/src/single/crotg.c @@ -0,0 +1,232 @@ +#include +#include +#include + +#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; +} diff --git a/src/cscal.c b/src/single/cscal.c similarity index 83% rename from src/cscal.c rename to src/single/cscal.c index 85a4d8b..061d973 100644 --- a/src/cscal.c +++ b/src/single/cscal.c @@ -1,7 +1,5 @@ #include -#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 } - diff --git a/src/csrot.c b/src/single/csrot.c similarity index 74% rename from src/csrot.c rename to src/single/csrot.c index 2e354ef..0a74713 100644 --- a/src/csrot.c +++ b/src/single/csrot.c @@ -1,7 +1,5 @@ #include -#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 diff --git a/src/csscal.c b/src/single/csscal.c similarity index 76% rename from src/csscal.c rename to src/single/csscal.c index 7467b1e..ea8c1e0 100644 --- a/src/csscal.c +++ b/src/single/csscal.c @@ -1,7 +1,5 @@ #include -#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 diff --git a/src/cswap.c b/src/single/cswap.c similarity index 69% rename from src/cswap.c rename to src/single/cswap.c index 64d6b9d..95e8fed 100644 --- a/src/cswap.c +++ b/src/single/cswap.c @@ -1,7 +1,5 @@ #include -#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 diff --git a/src/csymm.c b/src/single/csymm.c similarity index 54% rename from src/csymm.c rename to src/single/csymm.c index ff6a6bf..93cbb64 100644 --- a/src/csymm.c +++ b/src/single/csymm.c @@ -1,3 +1,10 @@ +#include +#include +#include + +#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 + +} diff --git a/src/single/csyr2k.c b/src/single/csyr2k.c new file mode 100644 index 0000000..91350e1 --- /dev/null +++ b/src/single/csyr2k.c @@ -0,0 +1,358 @@ +#include +#include +#include + +#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 + +} diff --git a/src/single/csyrk.c b/src/single/csyrk.c new file mode 100644 index 0000000..84cc25b --- /dev/null +++ b/src/single/csyrk.c @@ -0,0 +1,329 @@ +#include +#include +#include + +#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. + +} diff --git a/src/single/ctbmv.c b/src/single/ctbmv.c new file mode 100644 index 0000000..3aa85c5 --- /dev/null +++ b/src/single/ctbmv.c @@ -0,0 +1,427 @@ +#include +#include +#include + +#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 + +} diff --git a/src/single/ctbsv.c b/src/single/ctbsv.c new file mode 100644 index 0000000..fb5f8e5 --- /dev/null +++ b/src/single/ctbsv.c @@ -0,0 +1,432 @@ +#include +#include +#include + +#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 + +} diff --git a/src/single/ctpmv.c b/src/single/ctpmv.c new file mode 100644 index 0000000..c712683 --- /dev/null +++ b/src/single/ctpmv.c @@ -0,0 +1,380 @@ +#include +#include + +#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 + +} diff --git a/src/single/ctpsv.c b/src/single/ctpsv.c new file mode 100644 index 0000000..65dd1eb --- /dev/null +++ b/src/single/ctpsv.c @@ -0,0 +1,385 @@ +#include +#include + +#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 + +} diff --git a/src/single/ctrmm.c b/src/single/ctrmm.c new file mode 100644 index 0000000..7b1923c --- /dev/null +++ b/src/single/ctrmm.c @@ -0,0 +1,427 @@ +#include +#include +#include + +#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 + +} diff --git a/src/single/ctrmv.c b/src/single/ctrmv.c new file mode 100644 index 0000000..ebc7692 --- /dev/null +++ b/src/single/ctrmv.c @@ -0,0 +1,370 @@ +#include +#include +#include + +#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 . + +} diff --git a/src/single/ctrsm.c b/src/single/ctrsm.c new file mode 100644 index 0000000..8194f54 --- /dev/null +++ b/src/single/ctrsm.c @@ -0,0 +1,444 @@ +#include +#include +#include + +#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 + +} diff --git a/src/single/ctrsv.c b/src/single/ctrsv.c new file mode 100644 index 0000000..e0cb561 --- /dev/null +++ b/src/single/ctrsv.c @@ -0,0 +1,372 @@ +#include +#include +#include + +#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 + +} diff --git a/src/single/icamax.c b/src/single/icamax.c new file mode 100644 index 0000000..c2226b1 --- /dev/null +++ b/src/single/icamax.c @@ -0,0 +1,132 @@ +#include +#include + +#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 + +} diff --git a/src/single/isamax.c b/src/single/isamax.c new file mode 100644 index 0000000..8f6708d --- /dev/null +++ b/src/single/isamax.c @@ -0,0 +1,129 @@ +#include + +#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 + +} diff --git a/src/single/sasum.c b/src/single/sasum.c new file mode 100644 index 0000000..9855a24 --- /dev/null +++ b/src/single/sasum.c @@ -0,0 +1,98 @@ +#include + +#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; +} diff --git a/src/single/saxpy.c b/src/single/saxpy.c new file mode 100644 index 0000000..d068050 --- /dev/null +++ b/src/single/saxpy.c @@ -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; +} diff --git a/src/single/scabs1.c b/src/single/scabs1.c new file mode 100644 index 0000000..193680b --- /dev/null +++ b/src/single/scabs1.c @@ -0,0 +1,59 @@ +#include +#include + +#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 ) ); +} diff --git a/src/single/scasum.c b/src/single/scasum.c new file mode 100644 index 0000000..c446527 --- /dev/null +++ b/src/single/scasum.c @@ -0,0 +1,114 @@ +#include +#include + +#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; +} diff --git a/src/single/scnrm2.c b/src/single/scnrm2.c new file mode 100644 index 0000000..34767e6 --- /dev/null +++ b/src/single/scnrm2.c @@ -0,0 +1,145 @@ +#include +#include + +#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; + +} diff --git a/src/single/scopy.c b/src/single/scopy.c new file mode 100644 index 0000000..8d60f3d --- /dev/null +++ b/src/single/scopy.c @@ -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 + +} diff --git a/src/single/sgemv.c b/src/single/sgemv.c new file mode 100644 index 0000000..a1b79d9 --- /dev/null +++ b/src/single/sgemv.c @@ -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; +} \ No newline at end of file diff --git a/src/single/sger.c b/src/single/sger.c new file mode 100644 index 0000000..09ac695 --- /dev/null +++ b/src/single/sger.c @@ -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; + +} \ No newline at end of file diff --git a/src/single/snrm2.c b/src/single/snrm2.c new file mode 100644 index 0000000..462c13f --- /dev/null +++ b/src/single/snrm2.c @@ -0,0 +1,184 @@ +#include +#include +#include + +/* +!> \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); + +} diff --git a/src/single/srotg.c b/src/single/srotg.c new file mode 100644 index 0000000..f3fee74 --- /dev/null +++ b/src/single/srotg.c @@ -0,0 +1,180 @@ +#include + +/* +!> \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; +} \ No newline at end of file diff --git a/src/single/sscal.c b/src/single/sscal.c new file mode 100644 index 0000000..96aa081 --- /dev/null +++ b/src/single/sscal.c @@ -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 + +} diff --git a/src/ctrmv.c b/src/single/strmv.c similarity index 62% rename from src/ctrmv.c rename to src/single/strmv.c index bc67b4a..0815e90 100644 --- a/src/ctrmv.c +++ b/src/single/strmv.c @@ -1,10 +1,7 @@ -#include -#include - -#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 -} +} \ No newline at end of file diff --git a/src/single/strsm.c b/src/single/strsm.c new file mode 100644 index 0000000..9d2243e --- /dev/null +++ b/src/single/strsm.c @@ -0,0 +1,442 @@ +#include + +#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 + +} \ No newline at end of file diff --git a/src/xerbla.c b/src/xerbla.c index 1cdd597..d8a98e1 100644 --- a/src/xerbla.c +++ b/src/xerbla.c @@ -1,6 +1,5 @@ #include - -#include "errquit.h" +#include /* *> \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 -} \ No newline at end of file +} diff --git a/src/xerbla_array.c b/src/xerbla_array.c index 1143094..50578b2 100644 --- a/src/xerbla_array.c +++ b/src/xerbla_array.c @@ -1,3 +1,8 @@ +#include + +#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