From f33185ce7fa343ef876f73ddebc44221bf0a7b44 Mon Sep 17 00:00:00 2001 From: Adam Parler Date: Sat, 8 Jul 2023 15:35:44 -0700 Subject: [PATCH] Added Reference BLAS files as starting point --- src/caxpy.c | 139 +++++++++++++ src/ccopy.c | 125 ++++++++++++ src/cdotc.c | 134 +++++++++++++ src/cdotu.c | 131 +++++++++++++ src/cgbmv.c | 387 ++++++++++++++++++++++++++++++++++++ src/cgemm.c | 477 +++++++++++++++++++++++++++++++++++++++++++++ src/cgemv.c | 347 +++++++++++++++++++++++++++++++++ src/cgerc.c | 224 +++++++++++++++++++++ src/cgeru.c | 224 +++++++++++++++++++++ src/chbmv.c | 377 +++++++++++++++++++++++++++++++++++ src/chemm.c | 368 ++++++++++++++++++++++++++++++++++ src/chemv.c | 334 +++++++++++++++++++++++++++++++ src/cher.c | 275 ++++++++++++++++++++++++++ src/cher2.c | 314 +++++++++++++++++++++++++++++ src/cher2k.c | 439 +++++++++++++++++++++++++++++++++++++++++ src/cherk.c | 393 +++++++++++++++++++++++++++++++++++++ src/chpmv.c | 335 +++++++++++++++++++++++++++++++ src/chpr.c | 276 ++++++++++++++++++++++++++ src/chpr2.c | 315 ++++++++++++++++++++++++++++++ src/crotg.c | 277 ++++++++++++++++++++++++++ src/cscal.c | 121 ++++++++++++ src/csrot.c | 153 +++++++++++++++ src/csscal.c | 124 ++++++++++++ src/cswap.c | 129 ++++++++++++ src/csymm.c | 366 ++++++++++++++++++++++++++++++++++ src/csyr2k.c | 393 +++++++++++++++++++++++++++++++++++++ src/csyrk.c | 360 ++++++++++++++++++++++++++++++++++ src/ctbmv.c | 426 ++++++++++++++++++++++++++++++++++++++++ src/ctbsv.c | 429 ++++++++++++++++++++++++++++++++++++++++ src/ctpmv.c | 385 ++++++++++++++++++++++++++++++++++++ src/ctpsv.c | 387 ++++++++++++++++++++++++++++++++++++ src/ctrmm.c | 449 ++++++++++++++++++++++++++++++++++++++++++ src/ctrmv.c | 370 +++++++++++++++++++++++++++++++++++ src/ctrsm.c | 474 ++++++++++++++++++++++++++++++++++++++++++++ src/ctrsv.c | 372 +++++++++++++++++++++++++++++++++++ src/dasum.c | 131 +++++++++++++ src/daxpy.c | 152 +++++++++++++++ src/dcabs1.c | 66 +++++++ src/dcopy.c | 146 ++++++++++++++ src/ddot.c | 148 ++++++++++++++ src/dgbmv.c | 367 ++++++++++++++++++++++++++++++++++ src/dgemm.c | 379 +++++++++++++++++++++++++++++++++++ src/dgemv.c | 327 +++++++++++++++++++++++++++++++ src/dger.c | 224 +++++++++++++++++++++ src/dnrm2.c | 199 +++++++++++++++++++ src/drot.c | 142 ++++++++++++++ src/drotg.c | 151 ++++++++++++++ src/drotm.c | 200 +++++++++++++++++++ src/drotmg.c | 260 ++++++++++++++++++++++++ src/dsbmv.c | 372 +++++++++++++++++++++++++++++++++++ src/dscal.c | 139 +++++++++++++ src/dsdot.c | 172 ++++++++++++++++ src/dspmv.c | 328 +++++++++++++++++++++++++++++++ src/dspr.c | 258 ++++++++++++++++++++++++ src/dspr2.c | 293 ++++++++++++++++++++++++++++ src/dswap.c | 153 +++++++++++++++ src/dsymm.c | 364 ++++++++++++++++++++++++++++++++++ src/dsymv.c | 330 +++++++++++++++++++++++++++++++ src/dsyr.c | 260 ++++++++++++++++++++++++ src/dsyr2.c | 295 ++++++++++++++++++++++++++++ src/dsyr2k.c | 396 +++++++++++++++++++++++++++++++++++++ src/dsyrk.c | 361 ++++++++++++++++++++++++++++++++++ src/dtbmv.c | 395 +++++++++++++++++++++++++++++++++++++ src/dtbsv.c | 398 +++++++++++++++++++++++++++++++++++++ src/dtpmv.c | 349 +++++++++++++++++++++++++++++++++ src/dtpsv.c | 351 +++++++++++++++++++++++++++++++++ src/dtrmm.c | 412 +++++++++++++++++++++++++++++++++++++++ src/dtrmv.c | 339 ++++++++++++++++++++++++++++++++ src/dtrsm.c | 440 +++++++++++++++++++++++++++++++++++++++++ src/dtrsv.c | 335 +++++++++++++++++++++++++++++++ src/dzasum.c | 118 +++++++++++ src/dznrm2.c | 209 ++++++++++++++++++++ src/icamax.c | 127 ++++++++++++ src/idamax.c | 126 ++++++++++++ src/isamax.c | 126 ++++++++++++ src/izamax.c | 127 ++++++++++++ src/lsame.c | 122 ++++++++++++ src/sasum.c | 132 +++++++++++++ src/saxpy.c | 152 +++++++++++++++ src/scabs1.c | 65 ++++++ src/scasum.c | 117 +++++++++++ src/scnrm2.c | 209 ++++++++++++++++++++ src/scopy.c | 146 ++++++++++++++ src/sdot.c | 148 ++++++++++++++ src/sdsdot.c | 163 ++++++++++++++++ src/sgbmv.c | 367 ++++++++++++++++++++++++++++++++++ src/sgemm.c | 379 +++++++++++++++++++++++++++++++++++ src/sgemv.c | 327 +++++++++++++++++++++++++++++++ src/sger.c | 224 +++++++++++++++++++++ src/snrm2.c | 199 +++++++++++++++++++ src/srot.c | 142 ++++++++++++++ src/srotg.c | 151 ++++++++++++++ src/srotm.c | 201 +++++++++++++++++++ src/srotmg.c | 260 ++++++++++++++++++++++++ src/ssbmv.c | 372 +++++++++++++++++++++++++++++++++++ src/sscal.c | 140 +++++++++++++ src/sspmv.c | 328 +++++++++++++++++++++++++++++++ src/sspr.c | 258 ++++++++++++++++++++++++ src/sspr2.c | 293 ++++++++++++++++++++++++++++ src/sswap.c | 153 +++++++++++++++ src/ssymm.c | 364 ++++++++++++++++++++++++++++++++++ src/ssymv.c | 330 +++++++++++++++++++++++++++++++ src/ssyr.c | 260 ++++++++++++++++++++++++ src/ssyr2.c | 295 ++++++++++++++++++++++++++++ src/ssyr2k.c | 396 +++++++++++++++++++++++++++++++++++++ src/ssyrk.c | 361 ++++++++++++++++++++++++++++++++++ src/stbmv.c | 395 +++++++++++++++++++++++++++++++++++++ src/stbsv.c | 398 +++++++++++++++++++++++++++++++++++++ src/stpmv.c | 349 +++++++++++++++++++++++++++++++++ src/stpsv.c | 351 +++++++++++++++++++++++++++++++++ src/strmm.c | 412 +++++++++++++++++++++++++++++++++++++++ src/strmv.c | 339 ++++++++++++++++++++++++++++++++ src/strsm.c | 440 +++++++++++++++++++++++++++++++++++++++++ src/strsv.c | 341 ++++++++++++++++++++++++++++++++ src/xerbla.c | 86 ++++++++ src/xerbla_array.c | 119 +++++++++++ src/zaxpy.c | 139 +++++++++++++ src/zcopy.c | 125 ++++++++++++ src/zdotc.c | 134 +++++++++++++ src/zdotu.c | 131 +++++++++++++ src/zdrot.c | 153 +++++++++++++++ src/zdscal.c | 123 ++++++++++++ src/zgbmv.c | 387 ++++++++++++++++++++++++++++++++++++ src/zgemm.c | 477 +++++++++++++++++++++++++++++++++++++++++++++ src/zgemv.c | 347 +++++++++++++++++++++++++++++++++ src/zgerc.c | 224 +++++++++++++++++++++ src/zgeru.c | 224 +++++++++++++++++++++ src/zhbmv.c | 377 +++++++++++++++++++++++++++++++++++ src/zhemm.c | 368 ++++++++++++++++++++++++++++++++++ src/zhemv.c | 334 +++++++++++++++++++++++++++++++ src/zher.c | 275 ++++++++++++++++++++++++++ src/zher2.c | 314 +++++++++++++++++++++++++++++ src/zher2k.c | 440 +++++++++++++++++++++++++++++++++++++++++ src/zherk.c | 393 +++++++++++++++++++++++++++++++++++++ src/zhpmv.c | 335 +++++++++++++++++++++++++++++++ src/zhpr.c | 276 ++++++++++++++++++++++++++ src/zhpr2.c | 315 ++++++++++++++++++++++++++++++ src/zrotg.c | 277 ++++++++++++++++++++++++++ src/zscal.c | 121 ++++++++++++ src/zswap.c | 129 ++++++++++++ src/zsymm.c | 366 ++++++++++++++++++++++++++++++++++ src/zsyr2k.c | 393 +++++++++++++++++++++++++++++++++++++ src/zsyrk.c | 360 ++++++++++++++++++++++++++++++++++ src/ztbmv.c | 426 ++++++++++++++++++++++++++++++++++++++++ src/ztbsv.c | 429 ++++++++++++++++++++++++++++++++++++++++ src/ztpmv.c | 385 ++++++++++++++++++++++++++++++++++++ src/ztpsv.c | 387 ++++++++++++++++++++++++++++++++++++ src/ztrmm.c | 449 ++++++++++++++++++++++++++++++++++++++++++ src/ztrmv.c | 370 +++++++++++++++++++++++++++++++++++ src/ztrsm.c | 474 ++++++++++++++++++++++++++++++++++++++++++++ src/ztrsv.c | 372 +++++++++++++++++++++++++++++++++++ 151 files changed, 42407 insertions(+) create mode 100644 src/caxpy.c create mode 100644 src/ccopy.c create mode 100644 src/cdotc.c create mode 100644 src/cdotu.c create mode 100644 src/cgbmv.c create mode 100644 src/cgemm.c create mode 100644 src/cgemv.c create mode 100644 src/cgerc.c create mode 100644 src/cgeru.c create mode 100644 src/chbmv.c create mode 100644 src/chemm.c create mode 100644 src/chemv.c create mode 100644 src/cher.c create mode 100644 src/cher2.c create mode 100644 src/cher2k.c create mode 100644 src/cherk.c create mode 100644 src/chpmv.c create mode 100644 src/chpr.c create mode 100644 src/chpr2.c create mode 100644 src/crotg.c create mode 100644 src/cscal.c create mode 100644 src/csrot.c create mode 100644 src/csscal.c create mode 100644 src/cswap.c create mode 100644 src/csymm.c create mode 100644 src/csyr2k.c create mode 100644 src/csyrk.c create mode 100644 src/ctbmv.c create mode 100644 src/ctbsv.c create mode 100644 src/ctpmv.c create mode 100644 src/ctpsv.c create mode 100644 src/ctrmm.c create mode 100644 src/ctrmv.c create mode 100644 src/ctrsm.c create mode 100644 src/ctrsv.c create mode 100644 src/dasum.c create mode 100644 src/daxpy.c create mode 100644 src/dcabs1.c create mode 100644 src/dcopy.c create mode 100644 src/ddot.c create mode 100644 src/dgbmv.c create mode 100644 src/dgemm.c create mode 100644 src/dgemv.c create mode 100644 src/dger.c create mode 100644 src/dnrm2.c create mode 100644 src/drot.c create mode 100644 src/drotg.c create mode 100644 src/drotm.c create mode 100644 src/drotmg.c create mode 100644 src/dsbmv.c create mode 100644 src/dscal.c create mode 100644 src/dsdot.c create mode 100644 src/dspmv.c create mode 100644 src/dspr.c create mode 100644 src/dspr2.c create mode 100644 src/dswap.c create mode 100644 src/dsymm.c create mode 100644 src/dsymv.c create mode 100644 src/dsyr.c create mode 100644 src/dsyr2.c create mode 100644 src/dsyr2k.c create mode 100644 src/dsyrk.c create mode 100644 src/dtbmv.c create mode 100644 src/dtbsv.c create mode 100644 src/dtpmv.c create mode 100644 src/dtpsv.c create mode 100644 src/dtrmm.c create mode 100644 src/dtrmv.c create mode 100644 src/dtrsm.c create mode 100644 src/dtrsv.c create mode 100644 src/dzasum.c create mode 100644 src/dznrm2.c create mode 100644 src/icamax.c create mode 100644 src/idamax.c create mode 100644 src/isamax.c create mode 100644 src/izamax.c create mode 100644 src/lsame.c create mode 100644 src/sasum.c create mode 100644 src/saxpy.c create mode 100644 src/scabs1.c create mode 100644 src/scasum.c create mode 100644 src/scnrm2.c create mode 100644 src/scopy.c create mode 100644 src/sdot.c create mode 100644 src/sdsdot.c create mode 100644 src/sgbmv.c create mode 100644 src/sgemm.c create mode 100644 src/sgemv.c create mode 100644 src/sger.c create mode 100644 src/snrm2.c create mode 100644 src/srot.c create mode 100644 src/srotg.c create mode 100644 src/srotm.c create mode 100644 src/srotmg.c create mode 100644 src/ssbmv.c create mode 100644 src/sscal.c create mode 100644 src/sspmv.c create mode 100644 src/sspr.c create mode 100644 src/sspr2.c create mode 100644 src/sswap.c create mode 100644 src/ssymm.c create mode 100644 src/ssymv.c create mode 100644 src/ssyr.c create mode 100644 src/ssyr2.c create mode 100644 src/ssyr2k.c create mode 100644 src/ssyrk.c create mode 100644 src/stbmv.c create mode 100644 src/stbsv.c create mode 100644 src/stpmv.c create mode 100644 src/stpsv.c create mode 100644 src/strmm.c create mode 100644 src/strmv.c create mode 100644 src/strsm.c create mode 100644 src/strsv.c create mode 100644 src/xerbla.c create mode 100644 src/xerbla_array.c create mode 100644 src/zaxpy.c create mode 100644 src/zcopy.c create mode 100644 src/zdotc.c create mode 100644 src/zdotu.c create mode 100644 src/zdrot.c create mode 100644 src/zdscal.c create mode 100644 src/zgbmv.c create mode 100644 src/zgemm.c create mode 100644 src/zgemv.c create mode 100644 src/zgerc.c create mode 100644 src/zgeru.c create mode 100644 src/zhbmv.c create mode 100644 src/zhemm.c create mode 100644 src/zhemv.c create mode 100644 src/zher.c create mode 100644 src/zher2.c create mode 100644 src/zher2k.c create mode 100644 src/zherk.c create mode 100644 src/zhpmv.c create mode 100644 src/zhpr.c create mode 100644 src/zhpr2.c create mode 100644 src/zrotg.c create mode 100644 src/zscal.c create mode 100644 src/zswap.c create mode 100644 src/zsymm.c create mode 100644 src/zsyr2k.c create mode 100644 src/zsyrk.c create mode 100644 src/ztbmv.c create mode 100644 src/ztbsv.c create mode 100644 src/ztpmv.c create mode 100644 src/ztpsv.c create mode 100644 src/ztrmm.c create mode 100644 src/ztrmv.c create mode 100644 src/ztrsm.c create mode 100644 src/ztrsv.c diff --git a/src/caxpy.c b/src/caxpy.c new file mode 100644 index 0000000..8dfdba9 --- /dev/null +++ b/src/caxpy.c @@ -0,0 +1,139 @@ +*> \brief \b CAXPY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CAXPY(N,CA,CX,INCX,CY,INCY) +* +* .. Scalar Arguments .. +* COMPLEX CA +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX CX(*),CY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CAXPY constant times a vector plus a vector. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] CA +*> \verbatim +*> CA is COMPLEX +*> On entry, CA specifies the scalar alpha. +*> \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 +*> +*> \param[in,out] CY +*> \verbatim +*> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of CY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CAXPY(N,CA,CX,INCX,CY,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..-- +* +* .. Scalar Arguments .. + COMPLEX CA + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX CX(*),CY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY +* .. +* .. External Functions .. + REAL SCABS1 + EXTERNAL SCABS1 +* .. + IF (N.LE.0) RETURN + IF (SCABS1(CA).EQ.0.0E+0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + CY(I) = CY(I) + CA*CX(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + CY(IY) = CY(IY) + CA*CX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF +* + RETURN +* +* End of CAXPY +* + END diff --git a/src/ccopy.c b/src/ccopy.c new file mode 100644 index 0000000..1b4999b --- /dev/null +++ b/src/ccopy.c @@ -0,0 +1,125 @@ +*> \brief \b CCOPY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCOPY(N,CX,INCX,CY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX CX(*),CY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCOPY copies a vector x to a vector y. +*> \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 +*> +*> \param[out] CY +*> \verbatim +*> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of CY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CCOPY(N,CX,INCX,CY,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX CX(*),CY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + CY(I) = CX(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + CY(IY) = CX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of CCOPY +* + END diff --git a/src/cdotc.c b/src/cdotc.c new file mode 100644 index 0000000..da29fdf --- /dev/null +++ b/src/cdotc.c @@ -0,0 +1,134 @@ +*> \brief \b CDOTC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX CX(*),CY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CDOTC forms the dot product of two complex vectors +*> CDOTC = X^H * Y +*> +*> \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 +*> +*> \param[in] CY +*> \verbatim +*> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of CY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX CX(*),CY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX CTEMP + INTEGER I,IX,IY +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG +* .. + CTEMP = (0.0,0.0) + CDOTC = (0.0,0.0) + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + CTEMP = CTEMP + CONJG(CX(I))*CY(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + CTEMP = CTEMP + CONJG(CX(IX))*CY(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + CDOTC = CTEMP + RETURN +* +* End of CDOTC +* + END diff --git a/src/cdotu.c b/src/cdotu.c new file mode 100644 index 0000000..d8c21d1 --- /dev/null +++ b/src/cdotu.c @@ -0,0 +1,131 @@ +*> \brief \b CDOTU +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* COMPLEX FUNCTION CDOTU(N,CX,INCX,CY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX CX(*),CY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CDOTU forms the dot product of two complex vectors +*> CDOTU = X^T * Y +*> +*> \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 +*> +*> \param[in] CY +*> \verbatim +*> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of CY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + COMPLEX FUNCTION CDOTU(N,CX,INCX,CY,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX CX(*),CY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX CTEMP + INTEGER I,IX,IY +* .. + CTEMP = (0.0,0.0) + CDOTU = (0.0,0.0) + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + CTEMP = CTEMP + CX(I)*CY(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + CTEMP = CTEMP + CX(IX)*CY(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + CDOTU = CTEMP + RETURN +* +* End of CDOTU +* + END diff --git a/src/cgbmv.c b/src/cgbmv.c new file mode 100644 index 0000000..42a1da0 --- /dev/null +++ b/src/cgbmv.c @@ -0,0 +1,387 @@ +*> \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/cgemm.c b/src/cgemm.c new file mode 100644 index 0000000..baefe21 --- /dev/null +++ b/src/cgemm.c @@ -0,0 +1,477 @@ +*> \brief \b CGEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,M,N +* CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGEMM performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T or op( X ) = X**H, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \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] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**H. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix +*> op( A ) and of the matrix C. 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 +*> op( B ) and the number of columns of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \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 TRANSA = 'N' or 'n', and is m otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading m by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \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 TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \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 TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \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, 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 CGEMM(TRANSA,TRANSB,M,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,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,J,L,NROWA,NROWB + LOGICAL CONJA,CONJB,NOTA,NOTB +* .. +* .. Parameters .. + COMPLEX ONE + PARAMETER (ONE= (1.0E+0,0.0E+0)) + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* +* 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 and NROWB as the number of rows of A and B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + CONJA = LSAME(TRANSA,'C') + CONJB = LSAME(TRANSB,'C') + IF (NOTA) THEN + NROWA = M + ELSE + NROWA = K + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.NOTA) .AND. (.NOT.CONJA) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CGEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (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 (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 (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 50 I = 1,M + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = 1,M + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE IF (CONJA) THEN +* +* Form C := alpha*A**H*B + beta*C. +* + DO 120 J = 1,N + DO 110 I = 1,M + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 150 J = 1,N + DO 140 I = 1,M + TEMP = ZERO + DO 130 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 130 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 140 CONTINUE + 150 CONTINUE + END IF + ELSE IF (NOTA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A*B**H + beta*C. +* + DO 200 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 160 I = 1,M + C(I,J) = ZERO + 160 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 170 I = 1,M + C(I,J) = BETA*C(I,J) + 170 CONTINUE + END IF + DO 190 L = 1,K + TEMP = ALPHA*CONJG(B(J,L)) + DO 180 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + ELSE +* +* Form C := alpha*A*B**T + beta*C +* + DO 250 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 210 I = 1,M + C(I,J) = ZERO + 210 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 220 I = 1,M + C(I,J) = BETA*C(I,J) + 220 CONTINUE + END IF + DO 240 L = 1,K + TEMP = ALPHA*B(J,L) + DO 230 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + END IF + ELSE IF (CONJA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A**H*B**H + beta*C. +* + DO 280 J = 1,N + DO 270 I = 1,M + TEMP = ZERO + DO 260 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*CONJG(B(J,L)) + 260 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 270 CONTINUE + 280 CONTINUE + ELSE +* +* Form C := alpha*A**H*B**T + beta*C +* + DO 310 J = 1,N + DO 300 I = 1,M + TEMP = ZERO + DO 290 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*B(J,L) + 290 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 300 CONTINUE + 310 CONTINUE + END IF + ELSE + IF (CONJB) THEN +* +* Form C := alpha*A**T*B**H + beta*C +* + DO 340 J = 1,N + DO 330 I = 1,M + TEMP = ZERO + DO 320 L = 1,K + TEMP = TEMP + A(L,I)*CONJG(B(J,L)) + 320 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 330 CONTINUE + 340 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 370 J = 1,N + DO 360 I = 1,M + TEMP = ZERO + DO 350 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 350 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 360 CONTINUE + 370 CONTINUE + END IF + END IF +* + RETURN +* +* End of CGEMM +* + END diff --git a/src/cgemv.c b/src/cgemv.c new file mode 100644 index 0000000..574be07 --- /dev/null +++ b/src/cgemv.c @@ -0,0 +1,347 @@ +*> \brief \b CGEMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA,BETA +* INTEGER INCX,INCY,LDA,M,N +* CHARACTER TRANS +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGEMV 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 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**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] 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 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 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 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 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 CGEMV(TRANS,M,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,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,KX,KY,LENX,LENY + LOGICAL NOCONJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX +* .. +* +* 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 (LDA.LT.MAX(1,M)) 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('CGEMV ',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 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 + 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) + DO 50 I = 1,M + Y(I) = Y(I) + TEMP*A(I,J) + 50 CONTINUE + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80 J = 1,N + TEMP = ALPHA*X(JX) + IY = KY + DO 70 I = 1,M + Y(IY) = Y(IY) + TEMP*A(I,J) + IY = IY + INCY + 70 CONTINUE + JX = JX + INCX + 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 + IF (NOCONJ) THEN + DO 90 I = 1,M + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + ELSE + DO 100 I = 1,M + TEMP = TEMP + CONJG(A(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 + IF (NOCONJ) THEN + DO 120 I = 1,M + TEMP = TEMP + A(I,J)*X(IX) + IX = IX + INCX + 120 CONTINUE + ELSE + DO 130 I = 1,M + TEMP = TEMP + CONJG(A(I,J))*X(IX) + IX = IX + INCX + 130 CONTINUE + END IF + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 140 CONTINUE + END IF + END IF +* + RETURN +* +* End of CGEMV +* + END diff --git a/src/cgerc.c b/src/cgerc.c new file mode 100644 index 0000000..716628d --- /dev/null +++ b/src/cgerc.c @@ -0,0 +1,224 @@ +*> \brief \b CGERC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA +* INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGERC performs the rank 1 operation +*> +*> A := alpha*x*y**H + 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 COMPLEX +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX 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 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, 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 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 CGERC(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 CONJG,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('CGERC ',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*CONJG(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*CONJG(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 CGERC +* + END diff --git a/src/cgeru.c b/src/cgeru.c new file mode 100644 index 0000000..5ff8f94 --- /dev/null +++ b/src/cgeru.c @@ -0,0 +1,224 @@ +*> \brief \b CGERU +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA +* INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGERU 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 COMPLEX +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX 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 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, 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 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 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 diff --git a/src/chbmv.c b/src/chbmv.c new file mode 100644 index 0000000..bddab93 --- /dev/null +++ b/src/chbmv.c @@ -0,0 +1,377 @@ +*> \brief \b CHBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA,BETA +* INTEGER INCX,INCY,K,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHBMV 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 band matrix, with k super-diagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the band matrix A is being supplied as +*> follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> being supplied. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> being supplied. +*> \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, K specifies the number of super-diagonals of the +*> matrix A. K must satisfy 0 .le. K. +*> \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 ( k + 1 ) +*> by n part of the array A must contain the upper triangular +*> band part of the hermitian matrix, 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 the upper +*> triangular part of a hermitian 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 hermitian matrix, 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 the lower +*> triangular part of a hermitian 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 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 +*> ( k + 1 ). +*> \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 +*> 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. +*> \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 +*> 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 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 diff --git a/src/chemm.c b/src/chemm.c new file mode 100644 index 0000000..5d66dda --- /dev/null +++ b/src/chemm.c @@ -0,0 +1,368 @@ +*> \brief \b CHEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA,BETA +* INTEGER LDA,LDB,LDC,M,N +* CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHEMM performs one of the matrix-matrix operations +*> +*> C := alpha*A*B + beta*C, +*> +*> or +*> +*> C := alpha*B*A + beta*C, +*> +*> where alpha and beta are scalars, A is an hermitian matrix and B and +*> C are m by n matrices. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether the hermitian matrix A +*> appears on the left or right in the operation as follows: +*> +*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C, +*> +*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C, +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the hermitian matrix A is to be +*> referenced as follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of the +*> hermitian matrix is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of the +*> hermitian matrix is to be referenced. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix C. +*> 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 C. +*> 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, ka ), where ka is +*> m when SIDE = 'L' or 'l' and is n otherwise. +*> Before entry with SIDE = 'L' or 'l', the m by m part of +*> the array A must contain the hermitian matrix, such that +*> when UPLO = 'U' or 'u', the leading m by m upper triangular +*> part of the array A must contain the upper triangular part +*> of the hermitian matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading m by m lower triangular part of the array A +*> must contain the lower triangular part of the hermitian +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> Before entry with SIDE = 'R' or 'r', the n by n part of +*> the array A must contain the hermitian matrix, such that +*> when UPLO = 'U' or 'u', the leading n by n upper triangular +*> part of the array A must contain the upper triangular part +*> of the hermitian matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading n by n lower triangular part of the array A +*> must contain the lower triangular part of the 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, they 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. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] 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. +*> \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 +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n updated +*> matrix. +*> \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, 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 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 diff --git a/src/chemv.c b/src/chemv.c new file mode 100644 index 0000000..288ab14 --- /dev/null +++ b/src/chemv.c @@ -0,0 +1,334 @@ +*> \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 new file mode 100644 index 0000000..2695a7e --- /dev/null +++ b/src/cher.c @@ -0,0 +1,275 @@ +*> \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 new file mode 100644 index 0000000..68976b4 --- /dev/null +++ b/src/cher2.c @@ -0,0 +1,314 @@ +*> \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 new file mode 100644 index 0000000..a779087 --- /dev/null +++ b/src/cher2k.c @@ -0,0 +1,439 @@ +*> \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 new file mode 100644 index 0000000..4b229c2 --- /dev/null +++ b/src/cherk.c @@ -0,0 +1,393 @@ +*> \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 new file mode 100644 index 0000000..459a9ba --- /dev/null +++ b/src/chpmv.c @@ -0,0 +1,335 @@ +*> \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 new file mode 100644 index 0000000..62a946f --- /dev/null +++ b/src/chpr.c @@ -0,0 +1,276 @@ +*> \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 new file mode 100644 index 0000000..cb07168 --- /dev/null +++ b/src/chpr2.c @@ -0,0 +1,315 @@ +*> \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 new file mode 100644 index 0000000..8704196 --- /dev/null +++ b/src/crotg.c @@ -0,0 +1,277 @@ +!> \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/cscal.c b/src/cscal.c new file mode 100644 index 0000000..4110988 --- /dev/null +++ b/src/cscal.c @@ -0,0 +1,121 @@ +*> \brief \b CSCAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CSCAL(N,CA,CX,INCX) +* +* .. Scalar Arguments .. +* COMPLEX CA +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX CX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSCAL scales a vector by a constant. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] CA +*> \verbatim +*> CA is COMPLEX +*> On entry, CA specifies the scalar alpha. +*> \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 CX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex_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 +*> +* ===================================================================== + SUBROUTINE CSCAL(N,CA,CX,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..-- +* +* .. Scalar Arguments .. + COMPLEX CA + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX CX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,NINCX +* .. +* .. Parameters .. + COMPLEX ONE + PARAMETER (ONE= (1.0E+0,0.0E+0)) +* .. + IF (N.LE.0 .OR. INCX.LE.0 .OR. CA.EQ.ONE) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DO I = 1,N + CX(I) = CA*CX(I) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + CX(I) = CA*CX(I) + END DO + END IF + RETURN +* +* End of CSCAL +* + END diff --git a/src/csrot.c b/src/csrot.c new file mode 100644 index 0000000..2b4b92b --- /dev/null +++ b/src/csrot.c @@ -0,0 +1,153 @@ +*> \brief \b CSROT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CSROT( N, CX, INCX, CY, INCY, C, S ) +* +* .. Scalar Arguments .. +* INTEGER INCX, INCY, N +* REAL C, S +* .. +* .. Array Arguments .. +* COMPLEX CX( * ), CY( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSROT applies a plane rotation, where the cos and sin (c and s) are real +*> and the vectors cx and cy are complex. +*> jack dongarra, linpack, 3/11/78. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the vectors cx and cy. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in,out] CX +*> \verbatim +*> CX is COMPLEX array, dimension at least +*> ( 1 + ( N - 1 )*abs( INCX ) ). +*> Before entry, the incremented array CX must contain the n +*> element vector cx. On exit, CX is overwritten by the updated +*> vector cx. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> CX. INCX must not be zero. +*> \endverbatim +*> +*> \param[in,out] CY +*> \verbatim +*> CY is COMPLEX array, dimension at least +*> ( 1 + ( N - 1 )*abs( INCY ) ). +*> Before entry, the incremented array CY must contain the n +*> element vector cy. On exit, CY is overwritten by the updated +*> vector cy. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> CY. INCY must not be zero. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is REAL +*> On entry, C specifies the cosine, cos. +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is REAL +*> On entry, S specifies the sine, sin. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex_blas_level1 +* +* ===================================================================== + SUBROUTINE CSROT( N, CX, INCX, CY, INCY, C, 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 .. + INTEGER INCX, INCY, N + REAL C, S +* .. +* .. Array Arguments .. + COMPLEX CX( * ), CY( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IX, IY + COMPLEX CTEMP +* .. +* .. Executable Statements .. +* + IF( N.LE.0 ) + $ RETURN + IF( INCX.EQ.1 .AND. INCY.EQ.1 ) THEN +* +* code for both increments equal to 1 +* + DO I = 1, N + CTEMP = C*CX( I ) + S*CY( I ) + CY( I ) = C*CY( I ) - S*CX( I ) + CX( I ) = CTEMP + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF( INCX.LT.0 ) + $ IX = ( -N+1 )*INCX + 1 + IF( INCY.LT.0 ) + $ IY = ( -N+1 )*INCY + 1 + DO I = 1, N + CTEMP = C*CX( IX ) + S*CY( IY ) + CY( IY ) = C*CY( IY ) - S*CX( IX ) + CX( IX ) = CTEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of CSROT +* + END diff --git a/src/csscal.c b/src/csscal.c new file mode 100644 index 0000000..b9a8ca5 --- /dev/null +++ b/src/csscal.c @@ -0,0 +1,124 @@ +*> \brief \b CSSCAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CSSCAL(N,SA,CX,INCX) +* +* .. Scalar Arguments .. +* REAL SA +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX CX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSSCAL scales a complex vector by a real constant. +*> \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] 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 complex_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 +*> +* ===================================================================== + SUBROUTINE CSSCAL(N,SA,CX,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..-- +* +* .. Scalar Arguments .. + REAL SA + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX CX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,NINCX +* .. +* .. Parameters .. + REAL ONE + PARAMETER (ONE=1.0E+0) +* .. +* .. Intrinsic Functions .. + INTRINSIC AIMAG,CMPLX,REAL +* .. + IF (N.LE.0 .OR. INCX.LE.0 .OR. SA.EQ.ONE) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DO I = 1,N + CX(I) = CMPLX(SA*REAL(CX(I)),SA*AIMAG(CX(I))) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + CX(I) = CMPLX(SA*REAL(CX(I)),SA*AIMAG(CX(I))) + END DO + END IF + RETURN +* +* End of CSSCAL +* + END diff --git a/src/cswap.c b/src/cswap.c new file mode 100644 index 0000000..310bf18 --- /dev/null +++ b/src/cswap.c @@ -0,0 +1,129 @@ +*> \brief \b CSWAP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CSWAP(N,CX,INCX,CY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX CX(*),CY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSWAP interchanges two vectors. +*> \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 CX +*> \endverbatim +*> +*> \param[in,out] CY +*> \verbatim +*> CY is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of CY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CSWAP(N,CX,INCX,CY,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX CX(*),CY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX CTEMP + INTEGER I,IX,IY +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 + DO I = 1,N + CTEMP = CX(I) + CX(I) = CY(I) + CY(I) = CTEMP + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + CTEMP = CX(IX) + CX(IX) = CY(IY) + CY(IY) = CTEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of CSWAP +* + END diff --git a/src/csymm.c b/src/csymm.c new file mode 100644 index 0000000..ff6a6bf --- /dev/null +++ b/src/csymm.c @@ -0,0 +1,366 @@ +*> \brief \b CSYMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA,BETA +* INTEGER LDA,LDB,LDC,M,N +* CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSYMM performs one of the matrix-matrix operations +*> +*> C := alpha*A*B + beta*C, +*> +*> or +*> +*> C := alpha*B*A + beta*C, +*> +*> where alpha and beta are scalars, A is a symmetric matrix and B and +*> C are m by n matrices. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether the symmetric matrix A +*> appears on the left or right in the operation as follows: +*> +*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C, +*> +*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C, +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the symmetric matrix A is to be +*> referenced as follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of the +*> symmetric matrix is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of the +*> symmetric matrix is to be referenced. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix C. +*> 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 C. +*> 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, ka ), where ka is +*> m when SIDE = 'L' or 'l' and is n otherwise. +*> Before entry with SIDE = 'L' or 'l', the m by m part of +*> the array A must contain the symmetric matrix, such that +*> when UPLO = 'U' or 'u', the leading m by m upper triangular +*> part of the array A must contain the upper triangular part +*> of the symmetric matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading m by m lower triangular part of the array A +*> must contain the lower triangular part of the symmetric +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> Before entry with SIDE = 'R' or 'r', the n by n part of +*> the array A must contain the symmetric matrix, such that +*> when UPLO = 'U' or 'u', the leading n by n upper triangular +*> part of the array A must contain the upper triangular part +*> of the symmetric matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading n by n lower triangular part of the array A +*> must contain the lower triangular part of the symmetric +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> \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 ), otherwise LDA must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] 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. +*> \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 +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n updated +*> matrix. +*> \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, 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 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 diff --git a/src/csyr2k.c b/src/csyr2k.c new file mode 100644 index 0000000..0975189 --- /dev/null +++ b/src/csyr2k.c @@ -0,0 +1,393 @@ +*> \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 new file mode 100644 index 0000000..97bde05 --- /dev/null +++ b/src/csyrk.c @@ -0,0 +1,360 @@ +*> \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 new file mode 100644 index 0000000..c0be8f4 --- /dev/null +++ b/src/ctbmv.c @@ -0,0 +1,426 @@ +*> \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 new file mode 100644 index 0000000..b3600e4 --- /dev/null +++ b/src/ctbsv.c @@ -0,0 +1,429 @@ +*> \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 new file mode 100644 index 0000000..b4651a2 --- /dev/null +++ b/src/ctpmv.c @@ -0,0 +1,385 @@ +*> \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 new file mode 100644 index 0000000..d306cc2 --- /dev/null +++ b/src/ctpsv.c @@ -0,0 +1,387 @@ +*> \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 new file mode 100644 index 0000000..2597372 --- /dev/null +++ b/src/ctrmm.c @@ -0,0 +1,449 @@ +*> \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/ctrmv.c b/src/ctrmv.c new file mode 100644 index 0000000..2404b3d --- /dev/null +++ b/src/ctrmv.c @@ -0,0 +1,370 @@ +*> \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 +*> +* ===================================================================== + SUBROUTINE CTRMV(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('CTRMV ',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 + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 10 I = 1,J - 1 + X(I) = X(I) + TEMP*A(I,J) + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 30 I = 1,J - 1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX + 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) + DO 50 I = N,J + 1,-1 + X(I) = X(I) + TEMP*A(I,J) + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,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 + DO 70 I = N,J + 1,-1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x or x := A**H*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 110 J = N,1,-1 + TEMP = X(J) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 90 I = J - 1,1,-1 + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*CONJG(A(J,J)) + DO 100 I = J - 1,1,-1 + TEMP = TEMP + CONJG(A(I,J))*X(I) + 100 CONTINUE + END IF + X(J) = TEMP + 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*A(J,J) + DO 120 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + A(I,J)*X(IX) + 120 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*CONJG(A(J,J)) + DO 130 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + CONJG(A(I,J))*X(IX) + 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) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = J + 1,N + TEMP = TEMP + A(I,J)*X(I) + 150 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*CONJG(A(J,J)) + DO 160 I = J + 1,N + TEMP = TEMP + CONJG(A(I,J))*X(I) + 160 CONTINUE + END IF + X(J) = TEMP + 170 CONTINUE + ELSE + JX = KX + DO 200 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 180 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + A(I,J)*X(IX) + 180 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*CONJG(A(J,J)) + DO 190 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + CONJG(A(I,J))*X(IX) + 190 CONTINUE + END IF + X(JX) = TEMP + JX = JX + INCX + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of CTRMV +* + END diff --git a/src/ctrsm.c b/src/ctrsm.c new file mode 100644 index 0000000..7da6cfe --- /dev/null +++ b/src/ctrsm.c @@ -0,0 +1,474 @@ +*> \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 new file mode 100644 index 0000000..de0640e --- /dev/null +++ b/src/ctrsv.c @@ -0,0 +1,372 @@ +*> \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/dasum.c b/src/dasum.c new file mode 100644 index 0000000..9a360b5 --- /dev/null +++ b/src/dasum.c @@ -0,0 +1,131 @@ +*> \brief \b DASUM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DASUM takes the sum of the absolute values. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_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 +*> +* ===================================================================== + DOUBLE PRECISION FUNCTION DASUM(N,DX,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,M,MP1,NINCX +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS,MOD +* .. + DASUM = 0.0d0 + DTEMP = 0.0d0 + IF (N.LE.0 .OR. INCX.LE.0) RETURN + IF (INCX.EQ.1) THEN +* code for increment equal to 1 +* +* +* clean-up loop +* + M = MOD(N,6) + IF (M.NE.0) THEN + DO I = 1,M + DTEMP = DTEMP + DABS(DX(I)) + END DO + IF (N.LT.6) THEN + DASUM = DTEMP + RETURN + END IF + END IF + MP1 = M + 1 + DO I = MP1,N,6 + DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I+1)) + + $ DABS(DX(I+2)) + DABS(DX(I+3)) + + $ DABS(DX(I+4)) + DABS(DX(I+5)) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + DTEMP = DTEMP + DABS(DX(I)) + END DO + END IF + DASUM = DTEMP + RETURN +* +* End of DASUM +* + END diff --git a/src/daxpy.c b/src/daxpy.c new file mode 100644 index 0000000..421f7c6 --- /dev/null +++ b/src/daxpy.c @@ -0,0 +1,152 @@ +*> \brief \b DAXPY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION DA +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*),DY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DAXPY 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] DA +*> \verbatim +*> DA is DOUBLE PRECISION +*> On entry, DA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +*> +*> \param[in,out] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of DY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DAXPY(N,DA,DX,INCX,DY,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..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION DA + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (DA.EQ.0.0d0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,4) + IF (M.NE.0) THEN + DO I = 1,M + DY(I) = DY(I) + DA*DX(I) + END DO + END IF + IF (N.LT.4) RETURN + MP1 = M + 1 + DO I = MP1,N,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) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + DY(IY) = DY(IY) + DA*DX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of DAXPY +* + END diff --git a/src/dcabs1.c b/src/dcabs1.c new file mode 100644 index 0000000..f6212a8 --- /dev/null +++ b/src/dcabs1.c @@ -0,0 +1,66 @@ +*> \brief \b DCABS1 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DCABS1(Z) +* +* .. Scalar Arguments .. +* COMPLEX*16 Z +* .. +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCABS1 computes |Re(.)| + |Im(.)| of a double complex number +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] Z +*> \verbatim +*> Z is COMPLEX*16 +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_blas_level1 +* +* ===================================================================== + DOUBLE PRECISION FUNCTION DCABS1(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..-- +* +* .. Scalar Arguments .. + COMPLEX*16 Z +* .. +* .. +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ABS,DBLE,DIMAG +* + DCABS1 = ABS(DBLE(Z)) + ABS(DIMAG(Z)) + RETURN +* +* End of DCABS1 +* + END diff --git a/src/dcopy.c b/src/dcopy.c new file mode 100644 index 0000000..ded46c5 --- /dev/null +++ b/src/dcopy.c @@ -0,0 +1,146 @@ +*> \brief \b DCOPY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*),DY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCOPY 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] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +*> +*> \param[out] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of DY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DCOPY(N,DX,INCX,DY,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,7) + IF (M.NE.0) THEN + DO I = 1,M + DY(I) = DX(I) + END DO + IF (N.LT.7) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,7 + DY(I) = DX(I) + DY(I+1) = DX(I+1) + DY(I+2) = DX(I+2) + DY(I+3) = DX(I+3) + DY(I+4) = DX(I+4) + DY(I+5) = DX(I+5) + DY(I+6) = DX(I+6) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + DY(IY) = DX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of DCOPY +* + END diff --git a/src/ddot.c b/src/ddot.c new file mode 100644 index 0000000..683a04b --- /dev/null +++ b/src/ddot.c @@ -0,0 +1,148 @@ +*> \brief \b DDOT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*),DY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DDOT forms the dot product of two vectors. +*> 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] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +*> +*> \param[in] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of DY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + DDOT = 0.0d0 + DTEMP = 0.0d0 + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,5) + IF (M.NE.0) THEN + DO I = 1,M + DTEMP = DTEMP + DX(I)*DY(I) + END DO + IF (N.LT.5) THEN + DDOT=DTEMP + RETURN + END IF + END IF + MP1 = M + 1 + DO I = MP1,N,5 + DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) + + $ DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + DTEMP = DTEMP + DX(IX)*DY(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + DDOT = DTEMP + RETURN +* +* End of DDOT +* + END diff --git a/src/dgbmv.c b/src/dgbmv.c new file mode 100644 index 0000000..4c8f088 --- /dev/null +++ b/src/dgbmv.c @@ -0,0 +1,367 @@ +*> \brief \b DGBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER INCX,INCY,KL,KU,LDA,M,N +* CHARACTER TRANS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGBMV 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 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**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] 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 DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION. +*> 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 DOUBLE PRECISION 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 double_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 DGBMV(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 .. + DOUBLE PRECISION ALPHA,BETA + INTEGER INCX,INCY,KL,KU,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,K,KUP1,KX,KY,LENX,LENY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC 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('DGBMV ',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 +* +* 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. +* + JY = KY + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = ZERO + K = KUP1 - J + DO 90 I = MAX(1,J-KU),MIN(M,J+KL) + TEMP = TEMP + A(K+I,J)*X(I) + 90 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 100 CONTINUE + ELSE + DO 120 J = 1,N + TEMP = ZERO + IX = KX + K = KUP1 - J + DO 110 I = MAX(1,J-KU),MIN(M,J+KL) + TEMP = TEMP + A(K+I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + IF (J.GT.KU) KX = KX + INCX + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGBMV +* + END diff --git a/src/dgemm.c b/src/dgemm.c new file mode 100644 index 0000000..8c1b4f2 --- /dev/null +++ b/src/dgemm.c @@ -0,0 +1,379 @@ +*> \brief \b DGEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,M,N +* CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEMM performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \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] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix +*> op( A ) and of the matrix C. 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 +*> op( B ) and the number of columns of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is m otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading m by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \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 TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \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 TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \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, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_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 DGEMM(TRANSA,TRANSB,M,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 .. + DOUBLE PRECISION ALPHA,BETA + INTEGER K,LDA,LDB,LDC,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,L,NROWA,NROWB + LOGICAL NOTA,NOTB +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* transposed and set NROWA and NROWB as the number of rows of A +* and B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + IF (NOTA) THEN + NROWA = M + ELSE + NROWA = K + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And if 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 (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 50 I = 1,M + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = 1,M + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 120 J = 1,N + DO 110 I = 1,M + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF (NOTA) THEN +* +* Form C := alpha*A*B**T + beta*C +* + DO 170 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 130 I = 1,M + C(I,J) = ZERO + 130 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 140 I = 1,M + C(I,J) = BETA*C(I,J) + 140 CONTINUE + END IF + DO 160 L = 1,K + TEMP = ALPHA*B(J,L) + DO 150 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 200 J = 1,N + DO 190 I = 1,M + TEMP = ZERO + DO 180 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 180 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMM +* + END diff --git a/src/dgemv.c b/src/dgemv.c new file mode 100644 index 0000000..6625509 --- /dev/null +++ b/src/dgemv.c @@ -0,0 +1,327 @@ +*> \brief \b DGEMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER INCX,INCY,LDA,M,N +* CHARACTER TRANS +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEMV 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 DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION. +*> 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 DOUBLE PRECISION 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 double_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 DGEMV(TRANS,M,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 .. + DOUBLE PRECISION ALPHA,BETA + INTEGER INCX,INCY,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* 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 (LDA.LT.MAX(1,M)) 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('DGEMV ',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 +* +* 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 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 + 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) + DO 50 I = 1,M + Y(I) = Y(I) + TEMP*A(I,J) + 50 CONTINUE + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80 J = 1,N + TEMP = ALPHA*X(JX) + IY = KY + DO 70 I = 1,M + Y(IY) = Y(IY) + TEMP*A(I,J) + IY = IY + INCY + 70 CONTINUE + JX = JX + INCX + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A**T*x + y. +* + JY = KY + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = ZERO + DO 90 I = 1,M + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 100 CONTINUE + ELSE + DO 120 J = 1,N + TEMP = ZERO + IX = KX + DO 110 I = 1,M + TEMP = TEMP + A(I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMV +* + END diff --git a/src/dger.c b/src/dger.c new file mode 100644 index 0000000..8c19cb4 --- /dev/null +++ b/src/dger.c @@ -0,0 +1,224 @@ +*> \brief \b DGER +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA +* INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGER 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 DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 double_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 DGER(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 .. + DOUBLE PRECISION ALPHA + INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION 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('DGER ',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 DGER +* + END diff --git a/src/dnrm2.c b/src/dnrm2.c new file mode 100644 index 0000000..06f7917 --- /dev/null +++ b/src/dnrm2.c @@ -0,0 +1,199 @@ +!> \brief \b DNRM2 +! +! =========== DOCUMENTATION =========== +! +! Online html documentation available at +! http://www.netlib.org/lapack/explore-html/ +! +! Definition: +! =========== +! +! DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX) +! +! .. Scalar Arguments .. +! INTEGER INCX,N +! .. +! .. Array Arguments .. +! DOUBLE PRECISION X(*) +! .. +! +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> DNRM2 returns the euclidean norm of a vector via the function +!> name, so that +!> +!> DNRM2 := 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 DOUBLE PRECISION 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 +!> +! ===================================================================== +function DNRM2( n, x, incx ) + integer, parameter :: wp = kind(1.d0) + real(wp) :: DNRM2 +! +! -- 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 .. + real(wp), parameter :: zero = 0.0_wp + real(wp), parameter :: one = 1.0_wp + real(wp), parameter :: maxN = huge(0.0_wp) +! .. +! .. Blue's scaling constants .. + real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( & + (minexponent(0._wp) - 1) * 0.5_wp) + real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( & + (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp) + real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( & + (minexponent(0._wp) - digits(0._wp)) * 0.5_wp)) + real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( & + (maxexponent(0._wp) + digits(0._wp) - 1) * 0.5_wp)) +! .. +! .. Scalar Arguments .. + integer :: incx, n +! .. +! .. Array Arguments .. + real(wp) :: x(*) +! .. +! .. Local Scalars .. + integer :: i, ix + logical :: notbig + real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin +! +! Quick return if possible +! + DNRM2 = zero + if( n <= 0 ) return +! + 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 + do i = 1, n + ax = abs(x(ix)) + if (ax > tbig) then + abig = abig + (ax*sbig)**2 + notbig = .false. + else if (ax < tsml) then + if (notbig) asml = asml + (ax*ssml)**2 + else + amed = amed + ax**2 + end if + ix = ix + incx + end do +! +! Combine abig and amed or amed and asml if more than one +! accumulator was used. +! + if (abig > zero) then +! +! Combine abig and amed if abig > 0. +! + if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then + abig = abig + (amed*sbig)*sbig + end if + scl = one / sbig + sumsq = abig + else if (asml > zero) then +! +! Combine amed and asml if asml > 0. +! + if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then + amed = sqrt(amed) + asml = sqrt(asml) / ssml + if (asml > amed) then + ymin = amed + ymax = asml + else + ymin = asml + ymax = amed + end if + scl = one + sumsq = ymax**2*( one + (ymin/ymax)**2 ) + else + scl = one / ssml + sumsq = asml + end if + else +! +! Otherwise all values are mid-range +! + scl = one + sumsq = amed + end if + DNRM2 = scl*sqrt( sumsq ) + return +end function diff --git a/src/drot.c b/src/drot.c new file mode 100644 index 0000000..0386626 --- /dev/null +++ b/src/drot.c @@ -0,0 +1,142 @@ +*> \brief \b DROT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION C,S +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*),DY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DROT applies a plane rotation. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +*> +*> \param[in,out] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of DY +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is DOUBLE PRECISION +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,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 PRECISION C,S + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,IX,IY +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + DTEMP = C*DX(I) + S*DY(I) + DY(I) = C*DY(I) - S*DX(I) + DX(I) = DTEMP + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + DTEMP = C*DX(IX) + S*DY(IY) + DY(IY) = C*DY(IY) - S*DX(IX) + DX(IX) = DTEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of DROT +* + END diff --git a/src/drotg.c b/src/drotg.c new file mode 100644 index 0000000..a344cd4 --- /dev/null +++ b/src/drotg.c @@ -0,0 +1,151 @@ +!> \brief \b DROTG +! +! =========== DOCUMENTATION =========== +! +! Online html documentation available at +! http://www.netlib.org/lapack/explore-html/ +! +! Definition: +! =========== +! +! DROTG 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 DOUBLE PRECISION +!> On entry, the scalar a. +!> On exit, the scalar r. +!> \endverbatim +!> +!> \param[in,out] B +!> \verbatim +!> B is DOUBLE PRECISION +!> On entry, the scalar b. +!> On exit, the scalar z. +!> \endverbatim +!> +!> \param[out] C +!> \verbatim +!> C is DOUBLE PRECISION +!> The scalar c. +!> \endverbatim +!> +!> \param[out] S +!> \verbatim +!> S is DOUBLE PRECISION +!> 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 +! +! ===================================================================== +subroutine DROTG( a, b, c, s ) + integer, parameter :: wp = kind(1.d0) +! +! -- 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 +! .. +! .. 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 & + ) +! .. +! .. Scalar Arguments .. + real(wp) :: a, b, c, s +! .. +! .. Local Scalars .. + real(wp) :: anorm, bnorm, scl, sigma, r, z +! .. + anorm = abs(a) + bnorm = abs(b) + if( bnorm == zero ) then + c = one + s = zero + b = zero + else if( anorm == zero ) then + c = zero + s = one + a = b + b = one + else + scl = min( safmax, max( safmin, anorm, bnorm ) ) + if( anorm > bnorm ) then + sigma = sign(one,a) + else + sigma = sign(one,b) + end if + r = sigma*( scl*sqrt((a/scl)**2 + (b/scl)**2) ) + c = a/r + s = b/r + if( anorm > bnorm ) then + z = s + else if( c /= zero ) then + z = one/c + else + z = one + end if + a = r + b = z + end if + return +end subroutine diff --git a/src/drotm.c b/src/drotm.c new file mode 100644 index 0000000..0363ddd --- /dev/null +++ b/src/drotm.c @@ -0,0 +1,200 @@ +*> \brief \b DROTM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DROTM(N,DX,INCX,DY,INCY,DPARAM) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DPARAM(5),DX(*),DY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX +*> +*> (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN +*> (DY**T) +*> +*> DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE +*> LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. +*> WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. +*> +*> DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 +*> +*> (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) +*> H=( ) ( ) ( ) ( ) +*> (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). +*> SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +*> +*> \param[in,out] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of DY +*> \endverbatim +*> +*> \param[in] DPARAM +*> \verbatim +*> DPARAM is DOUBLE PRECISION array, dimension (5) +*> DPARAM(1)=DFLAG +*> DPARAM(2)=DH11 +*> DPARAM(3)=DH21 +*> DPARAM(4)=DH12 +*> DPARAM(5)=DH22 +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_blas_level1 +* +* ===================================================================== + SUBROUTINE DROTM(N,DX,INCX,DY,INCY,DPARAM) +* +* -- 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 INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DPARAM(5),DX(*),DY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,TWO,W,Z,ZERO + INTEGER I,KX,KY,NSTEPS +* .. +* .. Data statements .. + DATA ZERO,TWO/0.D0,2.D0/ +* .. +* + DFLAG = DPARAM(1) + IF (N.LE.0 .OR. (DFLAG+TWO.EQ.ZERO)) RETURN + IF (INCX.EQ.INCY.AND.INCX.GT.0) THEN +* + NSTEPS = N*INCX + IF (DFLAG.LT.ZERO) THEN + DH11 = DPARAM(2) + DH12 = DPARAM(4) + DH21 = DPARAM(3) + DH22 = DPARAM(5) + DO I = 1,NSTEPS,INCX + W = DX(I) + Z = DY(I) + DX(I) = W*DH11 + Z*DH12 + DY(I) = W*DH21 + Z*DH22 + END DO + ELSE IF (DFLAG.EQ.ZERO) THEN + DH12 = DPARAM(4) + DH21 = DPARAM(3) + DO I = 1,NSTEPS,INCX + W = DX(I) + Z = DY(I) + DX(I) = W + Z*DH12 + DY(I) = W*DH21 + Z + END DO + ELSE + DH11 = DPARAM(2) + DH22 = DPARAM(5) + DO I = 1,NSTEPS,INCX + W = DX(I) + Z = DY(I) + DX(I) = W*DH11 + Z + DY(I) = -W + DH22*Z + END DO + END IF + ELSE + KX = 1 + KY = 1 + IF (INCX.LT.0) KX = 1 + (1-N)*INCX + IF (INCY.LT.0) KY = 1 + (1-N)*INCY +* + IF (DFLAG.LT.ZERO) THEN + DH11 = DPARAM(2) + DH12 = DPARAM(4) + DH21 = DPARAM(3) + DH22 = DPARAM(5) + DO I = 1,N + W = DX(KX) + Z = DY(KY) + DX(KX) = W*DH11 + Z*DH12 + DY(KY) = W*DH21 + Z*DH22 + KX = KX + INCX + KY = KY + INCY + END DO + ELSE IF (DFLAG.EQ.ZERO) THEN + DH12 = DPARAM(4) + DH21 = DPARAM(3) + DO I = 1,N + W = DX(KX) + Z = DY(KY) + DX(KX) = W + Z*DH12 + DY(KY) = W*DH21 + Z + KX = KX + INCX + KY = KY + INCY + END DO + ELSE + DH11 = DPARAM(2) + DH22 = DPARAM(5) + DO I = 1,N + W = DX(KX) + Z = DY(KY) + DX(KX) = W*DH11 + Z + DY(KY) = -W + DH22*Z + KX = KX + INCX + KY = KY + INCY + END DO + END IF + END IF + RETURN +* +* End of DROTM +* + END diff --git a/src/drotmg.c b/src/drotmg.c new file mode 100644 index 0000000..be59f31 --- /dev/null +++ b/src/drotmg.c @@ -0,0 +1,260 @@ +*> \brief \b DROTMG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION DD1,DD2,DX1,DY1 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DPARAM(5) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS +*> THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)*> DY2)**T. +*> WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. +*> +*> DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 +*> +*> (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) +*> H=( ) ( ) ( ) ( ) +*> (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). +*> LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 +*> RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE +*> VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) +*> +*> THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE +*> INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE +*> OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in,out] DD1 +*> \verbatim +*> DD1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in,out] DD2 +*> \verbatim +*> DD2 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in,out] DX1 +*> \verbatim +*> DX1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[in] DY1 +*> \verbatim +*> DY1 is DOUBLE PRECISION +*> \endverbatim +*> +*> \param[out] DPARAM +*> \verbatim +*> DPARAM is DOUBLE PRECISION array, dimension (5) +*> DPARAM(1)=DFLAG +*> DPARAM(2)=DH11 +*> DPARAM(3)=DH21 +*> DPARAM(4)=DH12 +*> DPARAM(5)=DH22 +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_blas_level1 +* +* ===================================================================== + SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM) +* +* -- 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 PRECISION DD1,DD2,DX1,DY1 +* .. +* .. Array Arguments .. + DOUBLE PRECISION DPARAM(5) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP, + $ DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS +* .. +* .. Data statements .. +* + DATA ZERO,ONE,TWO/0.D0,1.D0,2.D0/ + DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/ +* .. + + IF (DD1.LT.ZERO) THEN +* GO ZERO-H-D-AND-DX1.. + DFLAG = -ONE + DH11 = ZERO + DH12 = ZERO + DH21 = ZERO + DH22 = ZERO +* + DD1 = ZERO + DD2 = ZERO + DX1 = ZERO + ELSE +* CASE-DD1-NONNEGATIVE + DP2 = DD2*DY1 + IF (DP2.EQ.ZERO) THEN + DFLAG = -TWO + DPARAM(1) = DFLAG + RETURN + END IF +* REGULAR-CASE.. + DP1 = DD1*DX1 + DQ2 = DP2*DY1 + DQ1 = DP1*DX1 +* + IF (DABS(DQ1).GT.DABS(DQ2)) THEN + DH21 = -DY1/DX1 + DH12 = DP2/DP1 +* + DU = ONE - DH12*DH21 +* + IF (DU.GT.ZERO) THEN + DFLAG = ZERO + DD1 = DD1/DU + DD2 = DD2/DU + DX1 = DX1*DU + ELSE +* This code path if here for safety. We do not expect this +* condition to ever hold except in edge cases with rounding +* errors. See DOI: 10.1145/355841.355847 + DFLAG = -ONE + DH11 = ZERO + DH12 = ZERO + DH21 = ZERO + DH22 = ZERO +* + DD1 = ZERO + DD2 = ZERO + DX1 = ZERO + END IF + ELSE + + IF (DQ2.LT.ZERO) THEN +* GO ZERO-H-D-AND-DX1.. + DFLAG = -ONE + DH11 = ZERO + DH12 = ZERO + DH21 = ZERO + DH22 = ZERO +* + DD1 = ZERO + DD2 = ZERO + DX1 = ZERO + ELSE + DFLAG = ONE + DH11 = DP1/DP2 + DH22 = DX1/DY1 + DU = ONE + DH11*DH22 + DTEMP = DD2/DU + DD2 = DD1/DU + DD1 = DTEMP + DX1 = DY1*DU + END IF + END IF + +* PROCEDURE..SCALE-CHECK + IF (DD1.NE.ZERO) THEN + DO WHILE ((DD1.LE.RGAMSQ) .OR. (DD1.GE.GAMSQ)) + IF (DFLAG.EQ.ZERO) THEN + DH11 = ONE + DH22 = ONE + DFLAG = -ONE + ELSE + DH21 = -ONE + DH12 = ONE + DFLAG = -ONE + END IF + IF (DD1.LE.RGAMSQ) THEN + DD1 = DD1*GAM**2 + DX1 = DX1/GAM + DH11 = DH11/GAM + DH12 = DH12/GAM + ELSE + DD1 = DD1/GAM**2 + DX1 = DX1*GAM + DH11 = DH11*GAM + DH12 = DH12*GAM + END IF + ENDDO + END IF + + IF (DD2.NE.ZERO) THEN + DO WHILE ( (DABS(DD2).LE.RGAMSQ) .OR. (DABS(DD2).GE.GAMSQ) ) + IF (DFLAG.EQ.ZERO) THEN + DH11 = ONE + DH22 = ONE + DFLAG = -ONE + ELSE + DH21 = -ONE + DH12 = ONE + DFLAG = -ONE + END IF + IF (DABS(DD2).LE.RGAMSQ) THEN + DD2 = DD2*GAM**2 + DH21 = DH21/GAM + DH22 = DH22/GAM + ELSE + DD2 = DD2/GAM**2 + DH21 = DH21*GAM + DH22 = DH22*GAM + END IF + END DO + END IF + + END IF + + IF (DFLAG.LT.ZERO) THEN + DPARAM(2) = DH11 + DPARAM(3) = DH21 + DPARAM(4) = DH12 + DPARAM(5) = DH22 + ELSE IF (DFLAG.EQ.ZERO) THEN + DPARAM(3) = DH21 + DPARAM(4) = DH12 + ELSE + DPARAM(2) = DH11 + DPARAM(5) = DH22 + END IF + + DPARAM(1) = DFLAG + RETURN +* +* End of DROTMG +* + END diff --git a/src/dsbmv.c b/src/dsbmv.c new file mode 100644 index 0000000..ad9e418 --- /dev/null +++ b/src/dsbmv.c @@ -0,0 +1,372 @@ +*> \brief \b DSBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER INCX,INCY,K,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSBMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n symmetric band matrix, with k super-diagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the band matrix A is being supplied as +*> follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> being supplied. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> being supplied. +*> \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, K specifies the number of super-diagonals of the +*> matrix A. K must satisfy 0 .le. K. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION 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 symmetric matrix, 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 the upper +*> triangular part of a symmetric 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 symmetric matrix, 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 the lower +*> triangular part of a symmetric 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 +*> \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] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> 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 DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is DOUBLE PRECISION array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> 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 double_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 DSBMV(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 .. + DOUBLE PRECISION ALPHA,BETA + INTEGER INCX,INCY,K,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION 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 MAX,MIN +* .. +* +* 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('DSBMV ',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 + A(L+I,J)*X(I) + 50 CONTINUE + Y(J) = Y(J) + TEMP1*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 + A(L+I,J)*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*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*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 + 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*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 + 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 DSBMV +* + END diff --git a/src/dscal.c b/src/dscal.c new file mode 100644 index 0000000..e055d19 --- /dev/null +++ b/src/dscal.c @@ -0,0 +1,139 @@ +*> \brief \b DSCAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSCAL(N,DA,DX,INCX) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION DA +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSCAL 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] DA +*> \verbatim +*> DA is DOUBLE PRECISION +*> On entry, DA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in,out] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_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 +*> +* ===================================================================== + SUBROUTINE DSCAL(N,DA,DX,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..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION DA + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,M,MP1,NINCX +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER (ONE=1.0D+0) +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0 .OR. INCX.LE.0 .OR. DA.EQ.ONE) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* +* +* clean-up loop +* + M = MOD(N,5) + IF (M.NE.0) THEN + DO I = 1,M + DX(I) = DA*DX(I) + END DO + IF (N.LT.5) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,5 + DX(I) = DA*DX(I) + DX(I+1) = DA*DX(I+1) + DX(I+2) = DA*DX(I+2) + DX(I+3) = DA*DX(I+3) + DX(I+4) = DA*DX(I+4) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + DX(I) = DA*DX(I) + END DO + END IF + RETURN +* +* End of DSCAL +* + END diff --git a/src/dsdot.c b/src/dsdot.c new file mode 100644 index 0000000..ae254a6 --- /dev/null +++ b/src/dsdot.c @@ -0,0 +1,172 @@ +*> \brief \b DSDOT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DSDOT(N,SX,INCX,SY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* REAL SX(*),SY(*) +* .. +* +* AUTHORS +* ======= +* Lawson, C. L., (JPL), Hanson, R. J., (SNLA), +* Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Compute the inner product of two vectors with extended +*> precision accumulation and result. +*> +*> Returns D.P. dot product accumulated in D.P., for S.P. SX and SY +*> DSDOT = sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY), +*> where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is +*> defined in a similar way using INCY. +*> \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(N) +*> single precision vector with N elements +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of SX +*> \endverbatim +*> +*> \param[in] SY +*> \verbatim +*> SY is REAL array, dimension(N) +*> single precision vector with N elements +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of SY +*> \endverbatim +*> +*> \result DSDOT +*> \verbatim +*> DSDOT is DOUBLE PRECISION +*> DSDOT double precision dot product (zero if N.LE.0) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> \endverbatim +* +*> \par References: +* ================ +*> +*> \verbatim +*> +*> +*> C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. +*> Krogh, Basic linear algebra subprograms for Fortran +*> usage, Algorithm No. 539, Transactions on Mathematical +*> Software 5, 3 (September 1979), pp. 308-323. +*> +*> REVISION HISTORY (YYMMDD) +*> +*> 791001 DATE WRITTEN +*> 890831 Modified array declarations. (WRB) +*> 890831 REVISION DATE from Version 3.2 +*> 891214 Prologue converted to Version 4.0 format. (BAB) +*> 920310 Corrected definition of LX in DESCRIPTION. (WRB) +*> 920501 Reformatted the REFERENCES section. (WRB) +*> 070118 Reformat to LAPACK style (JL) +*> \endverbatim +*> +* ===================================================================== + DOUBLE PRECISION FUNCTION DSDOT(N,SX,INCX,SY,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + REAL SX(*),SY(*) +* .. +* +* Authors: +* ======== +* Lawson, C. L., (JPL), Hanson, R. J., (SNLA), +* Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,KX,KY,NS +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. + DSDOT = 0.0D0 + IF (N.LE.0) RETURN + IF (INCX.EQ.INCY .AND. INCX.GT.0) THEN +* +* Code for equal, positive, non-unit increments. +* + NS = N*INCX + DO I = 1,NS,INCX + DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I)) + END DO + ELSE +* +* Code for unequal or nonpositive increments. +* + KX = 1 + KY = 1 + IF (INCX.LT.0) KX = 1 + (1-N)*INCX + IF (INCY.LT.0) KY = 1 + (1-N)*INCY + DO I = 1,N + DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY)) + KX = KX + INCX + KY = KY + INCY + END DO + END IF + RETURN +* +* End of DSDOT +* + END diff --git a/src/dspmv.c b/src/dspmv.c new file mode 100644 index 0000000..a79c74d --- /dev/null +++ b/src/dspmv.c @@ -0,0 +1,328 @@ +*> \brief \b DSPMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER INCX,INCY,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP(*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSPMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n symmetric matrix, 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 DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION 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 symmetric 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 symmetric 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. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION 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 DOUBLE PRECISION. +*> 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 DOUBLE PRECISION 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 double_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 DSPMV(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 .. + DOUBLE PRECISION ALPHA,BETA + INTEGER INCX,INCY,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP(*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* 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('DSPMV ',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 + AP(K)*X(I) + K = K + 1 + 50 CONTINUE + Y(J) = Y(J) + TEMP1*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 + AP(K)*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*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*AP(KK) + K = KK + 1 + DO 90 I = J + 1,N + Y(I) = Y(I) + TEMP1*AP(K) + TEMP2 = TEMP2 + 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*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 + 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 DSPMV +* + END diff --git a/src/dspr.c b/src/dspr.c new file mode 100644 index 0000000..67227a2 --- /dev/null +++ b/src/dspr.c @@ -0,0 +1,258 @@ +*> \brief \b DSPR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSPR(UPLO,N,ALPHA,X,INCX,AP) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA +* INTEGER INCX,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSPR performs the symmetric rank 1 operation +*> +*> A := alpha*x*x**T + A, +*> +*> where alpha is a real scalar, x is an n element vector and A is an +*> n by n symmetric 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 DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION 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 DOUBLE PRECISION 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 symmetric 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 symmetric 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_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 DSPR(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 .. + DOUBLE PRECISION ALPHA + INTEGER INCX,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* 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('DSPR ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.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*X(J) + K = KK + DO 10 I = 1,J + AP(K) = AP(K) + X(I)*TEMP + K = K + 1 + 10 CONTINUE + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*X(JX) + IX = KX + DO 30 K = KK,KK + J - 1 + AP(K) = AP(K) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + 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*X(J) + K = KK + DO 50 I = J,N + AP(K) = AP(K) + X(I)*TEMP + 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 + TEMP = ALPHA*X(JX) + IX = JX + DO 70 K = KK,KK + N - J + AP(K) = AP(K) + X(IX)*TEMP + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSPR +* + END diff --git a/src/dspr2.c b/src/dspr2.c new file mode 100644 index 0000000..0756c2b --- /dev/null +++ b/src/dspr2.c @@ -0,0 +1,293 @@ +*> \brief \b DSPR2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA +* INTEGER INCX,INCY,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP(*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSPR2 performs the symmetric rank 2 operation +*> +*> A := alpha*x*y**T + alpha*y*x**T + A, +*> +*> where alpha is a scalar, x and y are n element vectors and A is an +*> n by n symmetric 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 DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 symmetric 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 symmetric 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. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_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 DSPR2(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 .. + DOUBLE PRECISION ALPHA + INTEGER INCX,INCY,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP(*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* 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('DSPR2 ',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*Y(J) + TEMP2 = ALPHA*X(J) + K = KK + DO 10 I = 1,J + AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2 + K = K + 1 + 10 CONTINUE + 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*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = KX + IY = KY + DO 30 K = KK,KK + J - 1 + AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + 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*Y(J) + TEMP2 = ALPHA*X(J) + K = KK + DO 50 I = J,N + AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2 + K = K + 1 + 50 CONTINUE + 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*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = JX + IY = JY + DO 70 K = KK,KK + N - J + AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSPR2 +* + END diff --git a/src/dswap.c b/src/dswap.c new file mode 100644 index 0000000..b7600aa --- /dev/null +++ b/src/dswap.c @@ -0,0 +1,153 @@ +*> \brief \b DSWAP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*),DY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSWAP interchanges two vectors. +*> 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,out] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \endverbatim +*> +*> \param[in,out] DY +*> \verbatim +*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of DY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DSWAP(N,DX,INCX,DY,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,3) + IF (M.NE.0) THEN + DO I = 1,M + DTEMP = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP + END DO + IF (N.LT.3) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,3 + DTEMP = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP + DTEMP = DX(I+1) + DX(I+1) = DY(I+1) + DY(I+1) = DTEMP + DTEMP = DX(I+2) + DX(I+2) = DY(I+2) + DY(I+2) = DTEMP + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + DTEMP = DX(IX) + DX(IX) = DY(IY) + DY(IY) = DTEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of DSWAP +* + END diff --git a/src/dsymm.c b/src/dsymm.c new file mode 100644 index 0000000..683e79f --- /dev/null +++ b/src/dsymm.c @@ -0,0 +1,364 @@ +*> \brief \b DSYMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER LDA,LDB,LDC,M,N +* CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYMM performs one of the matrix-matrix operations +*> +*> C := alpha*A*B + beta*C, +*> +*> or +*> +*> C := alpha*B*A + beta*C, +*> +*> where alpha and beta are scalars, A is a symmetric matrix and B and +*> C are m by n matrices. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether the symmetric matrix A +*> appears on the left or right in the operation as follows: +*> +*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C, +*> +*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C, +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the symmetric matrix A is to be +*> referenced as follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of the +*> symmetric matrix is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of the +*> symmetric matrix is to be referenced. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix C. +*> 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 C. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is +*> m when SIDE = 'L' or 'l' and is n otherwise. +*> Before entry with SIDE = 'L' or 'l', the m by m part of +*> the array A must contain the symmetric matrix, such that +*> when UPLO = 'U' or 'u', the leading m by m upper triangular +*> part of the array A must contain the upper triangular part +*> of the symmetric matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading m by m lower triangular part of the array A +*> must contain the lower triangular part of the symmetric +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> Before entry with SIDE = 'R' or 'r', the n by n part of +*> the array A must contain the symmetric matrix, such that +*> when UPLO = 'U' or 'u', the leading n by n upper triangular +*> part of the array A must contain the upper triangular part +*> of the symmetric matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading n by n lower triangular part of the array A +*> must contain the lower triangular part of the symmetric +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> \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 ), otherwise LDA must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension ( LDB, N ) +*> Before entry, the leading m 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. LDB must be at least +*> max( 1, m ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n updated +*> matrix. +*> \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, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_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 DSYMM(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 .. + DOUBLE PRECISION ALPHA,BETA + INTEGER LDA,LDB,LDC,M,N + CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP1,TEMP2 + INTEGER I,INFO,J,K,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+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('DSYMM ',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 DSYMM +* + END diff --git a/src/dsymv.c b/src/dsymv.c new file mode 100644 index 0000000..17310d7 --- /dev/null +++ b/src/dsymv.c @@ -0,0 +1,330 @@ +*> \brief \b DSYMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER INCX,INCY,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n symmetric matrix. +*> \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 DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION 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 symmetric matrix and the strictly +*> lower triangular part of A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of A is not referenced. +*> \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 DOUBLE PRECISION 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 DOUBLE PRECISION. +*> 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 DOUBLE PRECISION 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 double_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 DSYMV(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 .. + DOUBLE PRECISION ALPHA,BETA + INTEGER INCX,INCY,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION 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 MAX +* .. +* +* 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('DSYMV ',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 + A(I,J)*X(I) + 50 CONTINUE + Y(J) = Y(J) + TEMP1*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 + A(I,J)*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*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*A(J,J) + DO 90 I = J + 1,N + Y(I) = Y(I) + TEMP1*A(I,J) + TEMP2 = TEMP2 + 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*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 + 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 DSYMV +* + END diff --git a/src/dsyr.c b/src/dsyr.c new file mode 100644 index 0000000..ab452dd --- /dev/null +++ b/src/dsyr.c @@ -0,0 +1,260 @@ +*> \brief \b DSYR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSYR(UPLO,N,ALPHA,X,INCX,A,LDA) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA +* INTEGER INCX,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYR performs the symmetric rank 1 operation +*> +*> A := alpha*x*x**T + A, +*> +*> where alpha is a real scalar, x is an n element vector and A is an +*> n by n symmetric 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 DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION 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 DOUBLE PRECISION 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 symmetric matrix and the strictly +*> lower triangular part of A is not referenced. On exit, the +*> upper triangular part of the array A is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of A is not referenced. On exit, the +*> lower triangular part of the array A is overwritten by the +*> lower triangular part of the updated matrix. +*> \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 double_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 DSYR(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 .. + DOUBLE PRECISION ALPHA + INTEGER INCX,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,KX +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* 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('DSYR ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.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*X(J) + DO 10 I = 1,J + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*X(JX) + IX = KX + DO 30 I = 1,J + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + 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*X(J) + DO 50 I = J,N + A(I,J) = A(I,J) + X(I)*TEMP + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*X(JX) + IX = JX + DO 70 I = J,N + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSYR +* + END diff --git a/src/dsyr2.c b/src/dsyr2.c new file mode 100644 index 0000000..4bad19b --- /dev/null +++ b/src/dsyr2.c @@ -0,0 +1,295 @@ +*> \brief \b DSYR2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA +* INTEGER INCX,INCY,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYR2 performs the symmetric rank 2 operation +*> +*> A := alpha*x*y**T + alpha*y*x**T + A, +*> +*> where alpha is a scalar, x and y are n element vectors and A is an n +*> by n symmetric 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 DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 symmetric matrix and the strictly +*> lower triangular part of A is not referenced. On exit, the +*> upper triangular part of the array A is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of A is not referenced. On exit, the +*> lower triangular part of the array A is overwritten by the +*> lower triangular part of the updated matrix. +*> \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 double_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 DSYR2(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 .. + DOUBLE PRECISION ALPHA + INTEGER INCX,INCY,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION 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 MAX +* .. +* +* 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('DSYR2 ',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*Y(J) + TEMP2 = ALPHA*X(J) + DO 10 I = 1,J + A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = KX + IY = KY + DO 30 I = 1,J + A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + 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*Y(J) + TEMP2 = ALPHA*X(J) + DO 50 I = J,N + A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + DO 80 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = JX + IY = JY + DO 70 I = J,N + A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSYR2 +* + END diff --git a/src/dsyr2k.c b/src/dsyr2k.c new file mode 100644 index 0000000..f5d16e0 --- /dev/null +++ b/src/dsyr2k.c @@ -0,0 +1,396 @@ +*> \brief \b DSYR2K +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYR2K 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. +*> +*> TRANS = 'C' or 'c' 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' or '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 DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION 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 double_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 DSYR2K(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 .. + DOUBLE PRECISION ALPHA,BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP1,TEMP2 + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+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')) .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('DSYR2K',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 DSYR2K +* + END diff --git a/src/dsyrk.c b/src/dsyrk.c new file mode 100644 index 0000000..0548c0c --- /dev/null +++ b/src/dsyrk.c @@ -0,0 +1,361 @@ +*> \brief \b DSYRK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER K,LDA,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYRK 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. +*> +*> TRANS = 'C' or 'c' 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' or '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 DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION 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 DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION 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 double_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 DSYRK(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 .. + DOUBLE PRECISION ALPHA,BETA + INTEGER K,LDA,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+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')) .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('DSYRK ',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 DSYRK +* + END diff --git a/src/dtbmv.c b/src/dtbmv.c new file mode 100644 index 0000000..646fb9b --- /dev/null +++ b/src/dtbmv.c @@ -0,0 +1,395 @@ +*> \brief \b DTBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,K,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTBMV performs one of the matrix-vector operations +*> +*> 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 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**T*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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 double_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 DTBMV(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 .. + DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC 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('DTBMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + 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. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 100 J = N,1,-1 + TEMP = X(J) + L = KPLUS1 - J + 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 + X(J) = TEMP + 100 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 120 J = N,1,-1 + TEMP = X(JX) + KX = KX - INCX + IX = KX + L = KPLUS1 - J + IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J) + DO 110 I = J - 1,MAX(1,J-K),-1 + TEMP = TEMP + A(L+I,J)*X(IX) + IX = IX - INCX + 110 CONTINUE + X(JX) = TEMP + JX = JX - INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = 1,N + TEMP = X(J) + L = 1 - J + IF (NOUNIT) TEMP = TEMP*A(1,J) + DO 130 I = J + 1,MIN(N,J+K) + TEMP = TEMP + A(L+I,J)*X(I) + 130 CONTINUE + X(J) = TEMP + 140 CONTINUE + ELSE + JX = KX + DO 160 J = 1,N + TEMP = X(JX) + KX = KX + INCX + IX = KX + L = 1 - J + IF (NOUNIT) TEMP = TEMP*A(1,J) + DO 150 I = J + 1,MIN(N,J+K) + TEMP = TEMP + A(L+I,J)*X(IX) + IX = IX + INCX + 150 CONTINUE + X(JX) = TEMP + JX = JX + INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTBMV +* + END diff --git a/src/dtbsv.c b/src/dtbsv.c new file mode 100644 index 0000000..d4ab7c6 --- /dev/null +++ b/src/dtbsv.c @@ -0,0 +1,398 @@ +*> \brief \b DTBSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,K,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTBSV solves one of the systems of equations +*> +*> A*x = b, or A**T*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**T*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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 double_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 DTBSV(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 .. + DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC 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('DTBSV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + 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. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = X(J) + L = KPLUS1 - J + 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) + X(J) = TEMP + 100 CONTINUE + ELSE + JX = KX + DO 120 J = 1,N + TEMP = X(JX) + IX = KX + L = KPLUS1 - J + DO 110 I = MAX(1,J-K),J - 1 + TEMP = TEMP - A(L+I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) + X(JX) = TEMP + JX = JX + INCX + IF (J.GT.K) KX = KX + INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = N,1,-1 + TEMP = X(J) + L = 1 - J + DO 130 I = MIN(N,J+K),J + 1,-1 + TEMP = TEMP - A(L+I,J)*X(I) + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(1,J) + X(J) = TEMP + 140 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 160 J = N,1,-1 + TEMP = X(JX) + IX = KX + L = 1 - J + DO 150 I = MIN(N,J+K),J + 1,-1 + TEMP = TEMP - A(L+I,J)*X(IX) + IX = IX - INCX + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(1,J) + X(JX) = TEMP + JX = JX - INCX + IF ((N-J).GE.K) KX = KX - INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTBSV +* + END diff --git a/src/dtpmv.c b/src/dtpmv.c new file mode 100644 index 0000000..32ab147 --- /dev/null +++ b/src/dtpmv.c @@ -0,0 +1,349 @@ +*> \brief \b DTPMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPMV performs one of the matrix-vector operations +*> +*> 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, 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**T*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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 double_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 DTPMV(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 .. + DOUBLE PRECISION AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* 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('DTPMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + 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. +* + IF (LSAME(UPLO,'U')) THEN + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 100 J = N,1,-1 + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*AP(KK) + K = KK - 1 + DO 90 I = J - 1,1,-1 + TEMP = TEMP + AP(K)*X(I) + K = K - 1 + 90 CONTINUE + X(J) = TEMP + KK = KK - J + 100 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 120 J = N,1,-1 + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*AP(KK) + DO 110 K = KK - 1,KK - J + 1,-1 + IX = IX - INCX + TEMP = TEMP + AP(K)*X(IX) + 110 CONTINUE + X(JX) = TEMP + JX = JX - INCX + KK = KK - J + 120 CONTINUE + END IF + ELSE + KK = 1 + IF (INCX.EQ.1) THEN + DO 140 J = 1,N + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*AP(KK) + K = KK + 1 + DO 130 I = J + 1,N + TEMP = TEMP + AP(K)*X(I) + K = K + 1 + 130 CONTINUE + X(J) = TEMP + KK = KK + (N-J+1) + 140 CONTINUE + ELSE + JX = KX + DO 160 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*AP(KK) + DO 150 K = KK + 1,KK + N - J + IX = IX + INCX + TEMP = TEMP + AP(K)*X(IX) + 150 CONTINUE + X(JX) = TEMP + JX = JX + INCX + KK = KK + (N-J+1) + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTPMV +* + END diff --git a/src/dtpsv.c b/src/dtpsv.c new file mode 100644 index 0000000..853d0da --- /dev/null +++ b/src/dtpsv.c @@ -0,0 +1,351 @@ +*> \brief \b DTPSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTPSV solves one of the systems of equations +*> +*> A*x = b, or A**T*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**T*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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 double_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 DTPSV(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 .. + DOUBLE PRECISION AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* 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('DTPSV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + 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. +* + IF (LSAME(UPLO,'U')) THEN + KK = 1 + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = X(J) + K = KK + 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) + X(J) = TEMP + KK = KK + J + 100 CONTINUE + ELSE + JX = KX + DO 120 J = 1,N + TEMP = X(JX) + IX = KX + DO 110 K = KK,KK + J - 2 + TEMP = TEMP - AP(K)*X(IX) + IX = IX + INCX + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK+J-1) + X(JX) = TEMP + JX = JX + INCX + KK = KK + J + 120 CONTINUE + END IF + ELSE + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 140 J = N,1,-1 + TEMP = X(J) + K = KK + DO 130 I = N,J + 1,-1 + TEMP = TEMP - AP(K)*X(I) + K = K - 1 + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK-N+J) + X(J) = TEMP + KK = KK - (N-J+1) + 140 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 160 J = N,1,-1 + TEMP = X(JX) + IX = KX + DO 150 K = KK,KK - (N- (J+1)),-1 + TEMP = TEMP - AP(K)*X(IX) + IX = IX - INCX + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK-N+J) + X(JX) = TEMP + JX = JX - INCX + KK = KK - (N-J+1) + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTPSV +* + END diff --git a/src/dtrmm.c b/src/dtrmm.c new file mode 100644 index 0000000..b2cc0a1 --- /dev/null +++ b/src/dtrmm.c @@ -0,0 +1,412 @@ +*> \brief \b DTRMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA +* INTEGER LDA,LDB,M,N +* CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),B(LDB,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTRMM 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. +*> \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**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 DOUBLE PRECISION. +*> 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 double_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 DTRMM(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 .. + DOUBLE PRECISION ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOUNIT,UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + 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('DTRMM ',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. +* + IF (UPPER) THEN + DO 110 J = 1,N + DO 100 I = M,1,-1 + TEMP = B(I,J) + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 90 K = 1,I - 1 + TEMP = TEMP + A(K,I)*B(K,J) + 90 CONTINUE + B(I,J) = ALPHA*TEMP + 100 CONTINUE + 110 CONTINUE + ELSE + DO 140 J = 1,N + DO 130 I = 1,M + TEMP = B(I,J) + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 120 K = I + 1,M + TEMP = TEMP + A(K,I)*B(K,J) + 120 CONTINUE + B(I,J) = ALPHA*TEMP + 130 CONTINUE + 140 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*A. +* + IF (UPPER) THEN + DO 180 J = N,1,-1 + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = 1,M + B(I,J) = TEMP*B(I,J) + 150 CONTINUE + DO 170 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 160 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + ELSE + DO 220 J = 1,N + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 190 I = 1,M + B(I,J) = TEMP*B(I,J) + 190 CONTINUE + DO 210 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 200 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 200 CONTINUE + END IF + 210 CONTINUE + 220 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*A**T. +* + IF (UPPER) THEN + DO 260 K = 1,N + DO 240 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + TEMP = ALPHA*A(J,K) + DO 230 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 230 CONTINUE + END IF + 240 CONTINUE + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(K,K) + IF (TEMP.NE.ONE) THEN + DO 250 I = 1,M + B(I,K) = TEMP*B(I,K) + 250 CONTINUE + END IF + 260 CONTINUE + ELSE + DO 300 K = N,1,-1 + DO 280 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + TEMP = ALPHA*A(J,K) + DO 270 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 270 CONTINUE + END IF + 280 CONTINUE + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(K,K) + IF (TEMP.NE.ONE) THEN + DO 290 I = 1,M + B(I,K) = TEMP*B(I,K) + 290 CONTINUE + END IF + 300 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRMM +* + END diff --git a/src/dtrmv.c b/src/dtrmv.c new file mode 100644 index 0000000..e8af8e6 --- /dev/null +++ b/src/dtrmv.c @@ -0,0 +1,339 @@ +*> \brief \b DTRMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTRMV performs one of the matrix-vector operations +*> +*> 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. +*> \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**T*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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 double_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 DTRMV(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 .. + DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC 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('DTRMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + 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 + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 10 I = 1,J - 1 + X(I) = X(I) + TEMP*A(I,J) + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 30 I = 1,J - 1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX + 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) + DO 50 I = N,J + 1,-1 + X(I) = X(I) + TEMP*A(I,J) + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,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 + DO 70 I = N,J + 1,-1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 100 J = N,1,-1 + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 90 I = J - 1,1,-1 + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + X(J) = TEMP + 100 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 120 J = N,1,-1 + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 110 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + A(I,J)*X(IX) + 110 CONTINUE + X(JX) = TEMP + JX = JX - INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = 1,N + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 130 I = J + 1,N + TEMP = TEMP + A(I,J)*X(I) + 130 CONTINUE + X(J) = TEMP + 140 CONTINUE + ELSE + JX = KX + DO 160 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + A(I,J)*X(IX) + 150 CONTINUE + X(JX) = TEMP + JX = JX + INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRMV +* + END diff --git a/src/dtrsm.c b/src/dtrsm.c new file mode 100644 index 0000000..fa8080b --- /dev/null +++ b/src/dtrsm.c @@ -0,0 +1,440 @@ +*> \brief \b DTRSM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA +* INTEGER LDA,LDB,M,N +* CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),B(LDB,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTRSM 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 DOUBLE PRECISION. +*> 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 double_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 DTRSM(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 .. + DOUBLE PRECISION ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOUNIT,UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + 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('DTRSM ',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. +* + IF (UPPER) THEN + DO 130 J = 1,N + DO 120 I = 1,M + TEMP = ALPHA*B(I,J) + DO 110 K = 1,I - 1 + TEMP = TEMP - A(K,I)*B(K,J) + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + B(I,J) = TEMP + 120 CONTINUE + 130 CONTINUE + ELSE + DO 160 J = 1,N + DO 150 I = M,1,-1 + TEMP = ALPHA*B(I,J) + DO 140 K = I + 1,M + TEMP = TEMP - A(K,I)*B(K,J) + 140 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + B(I,J) = TEMP + 150 CONTINUE + 160 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*inv( A ). +* + IF (UPPER) THEN + DO 210 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 170 I = 1,M + B(I,J) = ALPHA*B(I,J) + 170 CONTINUE + END IF + DO 190 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + DO 180 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 180 CONTINUE + END IF + 190 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 200 I = 1,M + B(I,J) = TEMP*B(I,J) + 200 CONTINUE + END IF + 210 CONTINUE + ELSE + DO 260 J = N,1,-1 + IF (ALPHA.NE.ONE) THEN + DO 220 I = 1,M + B(I,J) = ALPHA*B(I,J) + 220 CONTINUE + END IF + DO 240 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + DO 230 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 230 CONTINUE + END IF + 240 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 250 I = 1,M + B(I,J) = TEMP*B(I,J) + 250 CONTINUE + END IF + 260 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*inv( A**T ). +* + IF (UPPER) THEN + DO 310 K = N,1,-1 + IF (NOUNIT) THEN + TEMP = ONE/A(K,K) + DO 270 I = 1,M + B(I,K) = TEMP*B(I,K) + 270 CONTINUE + END IF + DO 290 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + TEMP = A(J,K) + DO 280 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 280 CONTINUE + END IF + 290 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 300 I = 1,M + B(I,K) = ALPHA*B(I,K) + 300 CONTINUE + END IF + 310 CONTINUE + ELSE + DO 360 K = 1,N + IF (NOUNIT) THEN + TEMP = ONE/A(K,K) + DO 320 I = 1,M + B(I,K) = TEMP*B(I,K) + 320 CONTINUE + END IF + DO 340 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + TEMP = A(J,K) + DO 330 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 330 CONTINUE + END IF + 340 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 350 I = 1,M + B(I,K) = ALPHA*B(I,K) + 350 CONTINUE + END IF + 360 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRSM +* + END diff --git a/src/dtrsv.c b/src/dtrsv.c new file mode 100644 index 0000000..d8ea9fa --- /dev/null +++ b/src/dtrsv.c @@ -0,0 +1,335 @@ +*> \brief \b DTRSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DTRSV solves one of the systems of equations +*> +*> A*x = b, or A**T*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**T*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 DOUBLE PRECISION 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 DOUBLE PRECISION 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. +*> +*> 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 +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_blas_level1 +* +* ===================================================================== + SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,LDA,N + CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D+0) +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC 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('DTRSV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + 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. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = X(J) + DO 90 I = 1,J - 1 + TEMP = TEMP - A(I,J)*X(I) + 90 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + X(J) = TEMP + 100 CONTINUE + ELSE + JX = KX + DO 120 J = 1,N + TEMP = X(JX) + IX = KX + DO 110 I = 1,J - 1 + TEMP = TEMP - A(I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + X(JX) = TEMP + JX = JX + INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = N,1,-1 + TEMP = X(J) + DO 130 I = N,J + 1,-1 + TEMP = TEMP - A(I,J)*X(I) + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + X(J) = TEMP + 140 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 160 J = N,1,-1 + TEMP = X(JX) + IX = KX + DO 150 I = N,J + 1,-1 + TEMP = TEMP - A(I,J)*X(IX) + IX = IX - INCX + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + X(JX) = TEMP + JX = JX - INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRSV +* + END diff --git a/src/dzasum.c b/src/dzasum.c new file mode 100644 index 0000000..7cc6ec5 --- /dev/null +++ b/src/dzasum.c @@ -0,0 +1,118 @@ +*> \brief \b DZASUM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* DOUBLE PRECISION FUNCTION DZASUM(N,ZX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DZASUM takes the sum of the (|Re(.)| + |Im(.)|)'s of a complex vector and +*> returns a double precision result. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + DOUBLE PRECISION FUNCTION DZASUM(N,ZX,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION STEMP + INTEGER I,NINCX +* .. +* .. External Functions .. + DOUBLE PRECISION DCABS1 + EXTERNAL DCABS1 +* .. + DZASUM = 0.0d0 + STEMP = 0.0d0 + IF (N.LE.0 .OR. INCX.LE.0) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DO I = 1,N + STEMP = STEMP + DCABS1(ZX(I)) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + STEMP = STEMP + DCABS1(ZX(I)) + END DO + END IF + DZASUM = STEMP + RETURN +* +* End of DZASUM +* + END diff --git a/src/dznrm2.c b/src/dznrm2.c new file mode 100644 index 0000000..0ca3c75 --- /dev/null +++ b/src/dznrm2.c @@ -0,0 +1,209 @@ +!> \brief \b DZNRM2 +! +! =========== DOCUMENTATION =========== +! +! Online html documentation available at +! http://www.netlib.org/lapack/explore-html/ +! +! Definition: +! =========== +! +! DOUBLE PRECISION FUNCTION DZNRM2(N,X,INCX) +! +! .. Scalar Arguments .. +! INTEGER INCX,N +! .. +! .. Array Arguments .. +! DOUBLE COMPLEX X(*) +! .. +! +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> DZNRM2 returns the euclidean norm of a vector via the function +!> name, so that +!> +!> DZNRM2 := 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*16 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 +!> +! ===================================================================== +function DZNRM2( n, x, incx ) + integer, parameter :: wp = kind(1.d0) + real(wp) :: DZNRM2 +! +! -- 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 .. + real(wp), parameter :: zero = 0.0_wp + real(wp), parameter :: one = 1.0_wp + real(wp), parameter :: maxN = huge(0.0_wp) +! .. +! .. Blue's scaling constants .. + real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( & + (minexponent(0._wp) - 1) * 0.5_wp) + real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( & + (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp) + real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( & + (minexponent(0._wp) - digits(0._wp)) * 0.5_wp)) + real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( & + (maxexponent(0._wp) + digits(0._wp) - 1) * 0.5_wp)) +! .. +! .. Scalar Arguments .. + integer :: incx, n +! .. +! .. Array Arguments .. + complex(wp) :: x(*) +! .. +! .. Local Scalars .. + integer :: i, ix + logical :: notbig + real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin +! +! Quick return if possible +! + DZNRM2 = zero + if( n <= 0 ) return +! + 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 + do i = 1, n + ax = abs(real(x(ix))) + if (ax > tbig) then + abig = abig + (ax*sbig)**2 + notbig = .false. + else if (ax < tsml) then + if (notbig) asml = asml + (ax*ssml)**2 + else + amed = amed + ax**2 + end if + ax = abs(aimag(x(ix))) + if (ax > tbig) then + abig = abig + (ax*sbig)**2 + notbig = .false. + else if (ax < tsml) then + if (notbig) asml = asml + (ax*ssml)**2 + else + amed = amed + ax**2 + end if + ix = ix + incx + end do +! +! Combine abig and amed or amed and asml if more than one +! accumulator was used. +! + if (abig > zero) then +! +! Combine abig and amed if abig > 0. +! + if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then + abig = abig + (amed*sbig)*sbig + end if + scl = one / sbig + sumsq = abig + else if (asml > zero) then +! +! Combine amed and asml if asml > 0. +! + if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then + amed = sqrt(amed) + asml = sqrt(asml) / ssml + if (asml > amed) then + ymin = amed + ymax = asml + else + ymin = asml + ymax = amed + end if + scl = one + sumsq = ymax**2*( one + (ymin/ymax)**2 ) + else + scl = one / ssml + sumsq = asml + end if + else +! +! Otherwise all values are mid-range +! + scl = one + sumsq = amed + end if + DZNRM2 = scl*sqrt( sumsq ) + return +end function diff --git a/src/icamax.c b/src/icamax.c new file mode 100644 index 0000000..c103cc8 --- /dev/null +++ b/src/icamax.c @@ -0,0 +1,127 @@ +*> \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 +*> +* ===================================================================== + INTEGER FUNCTION ICAMAX(N,CX,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX CX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL SMAX + INTEGER I,IX +* .. +* .. External Functions .. + REAL SCABS1 + EXTERNAL SCABS1 +* .. + ICAMAX = 0 + IF (N.LT.1 .OR. INCX.LE.0) RETURN + ICAMAX = 1 + IF (N.EQ.1) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + SMAX = SCABS1(CX(1)) + DO I = 2,N + IF (SCABS1(CX(I)).GT.SMAX) THEN + ICAMAX = I + SMAX = SCABS1(CX(I)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + IX = 1 + SMAX = SCABS1(CX(1)) + IX = IX + INCX + DO I = 2,N + IF (SCABS1(CX(IX)).GT.SMAX) THEN + ICAMAX = I + SMAX = SCABS1(CX(IX)) + END IF + IX = IX + INCX + END DO + END IF + RETURN +* +* End of ICAMAX +* + END diff --git a/src/idamax.c b/src/idamax.c new file mode 100644 index 0000000..1be301e --- /dev/null +++ b/src/idamax.c @@ -0,0 +1,126 @@ +*> \brief \b IDAMAX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* INTEGER FUNCTION IDAMAX(N,DX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION DX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> IDAMAX 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] DX +*> \verbatim +*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of DX +*> \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 +*> +* ===================================================================== + INTEGER FUNCTION IDAMAX(N,DX,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + DOUBLE PRECISION DX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DMAX + INTEGER I,IX +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS +* .. + IDAMAX = 0 + IF (N.LT.1 .OR. INCX.LE.0) RETURN + IDAMAX = 1 + IF (N.EQ.1) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DMAX = DABS(DX(1)) + DO I = 2,N + IF (DABS(DX(I)).GT.DMAX) THEN + IDAMAX = I + DMAX = DABS(DX(I)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + IX = 1 + DMAX = DABS(DX(1)) + IX = IX + INCX + DO I = 2,N + IF (DABS(DX(IX)).GT.DMAX) THEN + IDAMAX = I + DMAX = DABS(DX(IX)) + END IF + IX = IX + INCX + END DO + END IF + RETURN +* +* End of IDAMAX +* + END diff --git a/src/isamax.c b/src/isamax.c new file mode 100644 index 0000000..8ad44ad --- /dev/null +++ b/src/isamax.c @@ -0,0 +1,126 @@ +*> \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 +*> +* ===================================================================== + INTEGER FUNCTION ISAMAX(N,SX,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + REAL SX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL SMAX + INTEGER I,IX +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. + ISAMAX = 0 + IF (N.LT.1 .OR. INCX.LE.0) RETURN + ISAMAX = 1 + IF (N.EQ.1) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + SMAX = ABS(SX(1)) + DO I = 2,N + IF (ABS(SX(I)).GT.SMAX) THEN + ISAMAX = I + SMAX = ABS(SX(I)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + IX = 1 + SMAX = ABS(SX(1)) + IX = IX + INCX + DO I = 2,N + IF (ABS(SX(IX)).GT.SMAX) THEN + ISAMAX = I + SMAX = ABS(SX(IX)) + END IF + IX = IX + INCX + END DO + END IF + RETURN +* +* End of ISAMAX +* + END diff --git a/src/izamax.c b/src/izamax.c new file mode 100644 index 0000000..e4779a1 --- /dev/null +++ b/src/izamax.c @@ -0,0 +1,127 @@ +*> \brief \b IZAMAX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* INTEGER FUNCTION IZAMAX(N,ZX,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> IZAMAX 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] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \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, 1/15/85. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + INTEGER FUNCTION IZAMAX(N,ZX,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + DOUBLE PRECISION DMAX + INTEGER I,IX +* .. +* .. External Functions .. + DOUBLE PRECISION DCABS1 + EXTERNAL DCABS1 +* .. + IZAMAX = 0 + IF (N.LT.1 .OR. INCX.LE.0) RETURN + IZAMAX = 1 + IF (N.EQ.1) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DMAX = DCABS1(ZX(1)) + DO I = 2,N + IF (DCABS1(ZX(I)).GT.DMAX) THEN + IZAMAX = I + DMAX = DCABS1(ZX(I)) + END IF + END DO + ELSE +* +* code for increment not equal to 1 +* + IX = 1 + DMAX = DCABS1(ZX(1)) + IX = IX + INCX + DO I = 2,N + IF (DCABS1(ZX(IX)).GT.DMAX) THEN + IZAMAX = I + DMAX = DCABS1(ZX(IX)) + END IF + IX = IX + INCX + END DO + END IF + RETURN +* +* End of IZAMAX +* + END diff --git a/src/lsame.c b/src/lsame.c new file mode 100644 index 0000000..6aa4007 --- /dev/null +++ b/src/lsame.c @@ -0,0 +1,122 @@ +*> \brief \b LSAME +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* LOGICAL FUNCTION LSAME(CA,CB) +* +* .. Scalar Arguments .. +* CHARACTER CA,CB +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> LSAME returns .TRUE. if CA is the same letter as CB regardless of +*> case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] CA +*> \verbatim +*> CA is CHARACTER*1 +*> \endverbatim +*> +*> \param[in] CB +*> \verbatim +*> CB is CHARACTER*1 +*> CA and CB specify the single characters to be compared. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup aux_blas +* +* ===================================================================== + LOGICAL FUNCTION LSAME(CA,CB) +* +* -- 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 .. + CHARACTER CA,CB +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ICHAR +* .. +* .. Local Scalars .. + INTEGER INTA,INTB,ZCODE +* .. +* +* Test if the characters are equal +* + LSAME = CA .EQ. CB + IF (LSAME) RETURN +* +* Now test for equivalence if both characters are alphabetic. +* + ZCODE = ICHAR('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 = ICHAR(CA) + INTB = ICHAR(CB) +* + IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN +* +* ASCII is assumed - ZCODE is the ASCII code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32 + IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32 +* + ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN +* +* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.129 .AND. INTA.LE.137 .OR. + + INTA.GE.145 .AND. INTA.LE.153 .OR. + + INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64 + IF (INTB.GE.129 .AND. INTB.LE.137 .OR. + + INTB.GE.145 .AND. INTB.LE.153 .OR. + + INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64 +* + ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN +* +* ASCII is assumed, on Prime machines - ZCODE is the ASCII code +* plus 128 of either lower or upper case 'Z'. +* + IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32 + IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32 + END IF + LSAME = INTA .EQ. INTB +* +* RETURN +* +* End of LSAME +* + END diff --git a/src/sasum.c b/src/sasum.c new file mode 100644 index 0000000..6c2e0c9 --- /dev/null +++ b/src/sasum.c @@ -0,0 +1,132 @@ +*> \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 +*> +* ===================================================================== + REAL FUNCTION SASUM(N,SX,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + REAL SX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL STEMP + INTEGER I,M,MP1,NINCX +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS,MOD +* .. + SASUM = 0.0e0 + STEMP = 0.0e0 + IF (N.LE.0 .OR. INCX.LE.0) RETURN + IF (INCX.EQ.1) THEN +* code for increment equal to 1 +* +* +* clean-up loop +* + M = MOD(N,6) + IF (M.NE.0) THEN + DO I = 1,M + STEMP = STEMP + ABS(SX(I)) + END DO + IF (N.LT.6) THEN + SASUM = STEMP + RETURN + END IF + END IF + MP1 = M + 1 + DO I = MP1,N,6 + STEMP = STEMP + ABS(SX(I)) + ABS(SX(I+1)) + + $ ABS(SX(I+2)) + ABS(SX(I+3)) + + $ ABS(SX(I+4)) + ABS(SX(I+5)) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + STEMP = STEMP + ABS(SX(I)) + END DO + END IF + SASUM = STEMP + RETURN +* +* End of SASUM +* + END diff --git a/src/saxpy.c b/src/saxpy.c new file mode 100644 index 0000000..ded238a --- /dev/null +++ b/src/saxpy.c @@ -0,0 +1,152 @@ +*> \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 +*> +* ===================================================================== + SUBROUTINE SAXPY(N,SA,SX,INCX,SY,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..-- +* +* .. Scalar Arguments .. + REAL SA + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + REAL SX(*),SY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (SA.EQ.0.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,4) + IF (M.NE.0) THEN + DO I = 1,M + SY(I) = SY(I) + SA*SX(I) + END DO + END IF + IF (N.LT.4) RETURN + MP1 = M + 1 + DO I = MP1,N,4 + SY(I) = SY(I) + SA*SX(I) + SY(I+1) = SY(I+1) + SA*SX(I+1) + SY(I+2) = SY(I+2) + SA*SX(I+2) + SY(I+3) = SY(I+3) + SA*SX(I+3) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + SY(IY) = SY(IY) + SA*SX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of SAXPY +* + END diff --git a/src/scabs1.c b/src/scabs1.c new file mode 100644 index 0000000..9bacf09 --- /dev/null +++ b/src/scabs1.c @@ -0,0 +1,65 @@ +*> \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 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 +* +* ===================================================================== + REAL FUNCTION SCABS1(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..-- +* +* .. Scalar Arguments .. + COMPLEX Z +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ABS,AIMAG,REAL +* .. + SCABS1 = ABS(REAL(Z)) + ABS(AIMAG(Z)) + RETURN +* +* End of SCABS1 +* + END diff --git a/src/scasum.c b/src/scasum.c new file mode 100644 index 0000000..8fd67e9 --- /dev/null +++ b/src/scasum.c @@ -0,0 +1,117 @@ +*> \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 +*> +* ===================================================================== + REAL FUNCTION SCASUM(N,CX,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX CX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL STEMP + INTEGER I,NINCX +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS,AIMAG,REAL +* .. + SCASUM = 0.0e0 + STEMP = 0.0e0 + IF (N.LE.0 .OR. INCX.LE.0) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DO I = 1,N + STEMP = STEMP + ABS(REAL(CX(I))) + ABS(AIMAG(CX(I))) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + STEMP = STEMP + ABS(REAL(CX(I))) + ABS(AIMAG(CX(I))) + END DO + END IF + SCASUM = STEMP + RETURN +* +* End of SCASUM +* + END diff --git a/src/scnrm2.c b/src/scnrm2.c new file mode 100644 index 0000000..1c2b2d4 --- /dev/null +++ b/src/scnrm2.c @@ -0,0 +1,209 @@ +!> \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 +!> +! ===================================================================== +function SCNRM2( n, x, incx ) + integer, parameter :: wp = kind(1.e0) + real(wp) :: SCNRM2 +! +! -- 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 .. + real(wp), parameter :: zero = 0.0_wp + real(wp), parameter :: one = 1.0_wp + real(wp), parameter :: maxN = huge(0.0_wp) +! .. +! .. Blue's scaling constants .. + real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( & + (minexponent(0._wp) - 1) * 0.5_wp) + real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( & + (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp) + real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( & + (minexponent(0._wp) - digits(0._wp)) * 0.5_wp)) + real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( & + (maxexponent(0._wp) + digits(0._wp) - 1) * 0.5_wp)) +! .. +! .. Scalar Arguments .. + integer :: incx, n +! .. +! .. Array Arguments .. + complex(wp) :: x(*) +! .. +! .. Local Scalars .. + integer :: i, ix + logical :: notbig + real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin +! +! Quick return if possible +! + SCNRM2 = zero + if( n <= 0 ) return +! + 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 + do i = 1, n + ax = abs(real(x(ix))) + if (ax > tbig) then + abig = abig + (ax*sbig)**2 + notbig = .false. + else if (ax < tsml) then + if (notbig) asml = asml + (ax*ssml)**2 + else + amed = amed + ax**2 + end if + ax = abs(aimag(x(ix))) + if (ax > tbig) then + abig = abig + (ax*sbig)**2 + notbig = .false. + else if (ax < tsml) then + if (notbig) asml = asml + (ax*ssml)**2 + else + amed = amed + ax**2 + end if + ix = ix + incx + end do +! +! Combine abig and amed or amed and asml if more than one +! accumulator was used. +! + if (abig > zero) then +! +! Combine abig and amed if abig > 0. +! + if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then + abig = abig + (amed*sbig)*sbig + end if + scl = one / sbig + sumsq = abig + else if (asml > zero) then +! +! Combine amed and asml if asml > 0. +! + if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then + amed = sqrt(amed) + asml = sqrt(asml) / ssml + if (asml > amed) then + ymin = amed + ymax = asml + else + ymin = asml + ymax = amed + end if + scl = one + sumsq = ymax**2*( one + (ymin/ymax)**2 ) + else + scl = one / ssml + sumsq = asml + end if + else +! +! Otherwise all values are mid-range +! + scl = one + sumsq = amed + end if + SCNRM2 = scl*sqrt( sumsq ) + return +end function diff --git a/src/scopy.c b/src/scopy.c new file mode 100644 index 0000000..961025c --- /dev/null +++ b/src/scopy.c @@ -0,0 +1,146 @@ +*> \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 +*> +* ===================================================================== + SUBROUTINE SCOPY(N,SX,INCX,SY,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + REAL SX(*),SY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,7) + IF (M.NE.0) THEN + DO I = 1,M + SY(I) = SX(I) + END DO + IF (N.LT.7) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,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) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + SY(IY) = SX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of SCOPY +* + END diff --git a/src/sdot.c b/src/sdot.c new file mode 100644 index 0000000..ed7213e --- /dev/null +++ b/src/sdot.c @@ -0,0 +1,148 @@ +*> \brief \b SDOT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* REAL FUNCTION SDOT(N,SX,INCX,SY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* REAL SX(*),SY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SDOT forms the dot product of two vectors. +*> 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] 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] 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 +*> +* ===================================================================== + REAL FUNCTION SDOT(N,SX,INCX,SY,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + REAL SX(*),SY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL STEMP + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + STEMP = 0.0e0 + SDOT = 0.0e0 + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,5) + IF (M.NE.0) THEN + DO I = 1,M + STEMP = STEMP + SX(I)*SY(I) + END DO + IF (N.LT.5) THEN + SDOT=STEMP + RETURN + END IF + END IF + MP1 = M + 1 + DO I = MP1,N,5 + STEMP = STEMP + SX(I)*SY(I) + SX(I+1)*SY(I+1) + + $ SX(I+2)*SY(I+2) + SX(I+3)*SY(I+3) + SX(I+4)*SY(I+4) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + STEMP = STEMP + SX(IX)*SY(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + SDOT = STEMP + RETURN +* +* End of SDOT +* + END diff --git a/src/sdsdot.c b/src/sdsdot.c new file mode 100644 index 0000000..f70fee7 --- /dev/null +++ b/src/sdsdot.c @@ -0,0 +1,163 @@ +*> \brief \b SDSDOT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY) +* +* .. Scalar Arguments .. +* REAL SB +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* REAL SX(*),SY(*) +* .. +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Compute the inner product of two vectors with extended +*> precision accumulation. +*> +*> Returns S.P. result with dot product accumulated in D.P. +*> SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY), +*> where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is +*> defined in a similar way using INCY. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] SB +*> \verbatim +*> SB is REAL +*> single precision scalar to be added to inner product +*> \endverbatim +*> +*> \param[in] SX +*> \verbatim +*> SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> single precision vector with N elements +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of SX +*> \endverbatim +*> +*> \param[in] SY +*> \verbatim +*> SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> single precision vector with N elements +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of SY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Lawson, C. L., (JPL), Hanson, R. J., (SNLA), +*> \author Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) +* +*> \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 +*> +*> REFERENCES +*> +*> C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. +*> Krogh, Basic linear algebra subprograms for Fortran +*> usage, Algorithm No. 539, Transactions on Mathematical +*> Software 5, 3 (September 1979), pp. 308-323. +*> +*> REVISION HISTORY (YYMMDD) +*> +*> 791001 DATE WRITTEN +*> 890531 Changed all specific intrinsics to generic. (WRB) +*> 890831 Modified array declarations. (WRB) +*> 890831 REVISION DATE from Version 3.2 +*> 891214 Prologue converted to Version 4.0 format. (BAB) +*> 920310 Corrected definition of LX in DESCRIPTION. (WRB) +*> 920501 Reformatted the REFERENCES section. (WRB) +*> 070118 Reformat to LAPACK coding style +*> \endverbatim +*> +* ===================================================================== + REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,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..-- +* +* .. Scalar Arguments .. + REAL SB + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + REAL SX(*),SY(*) +* .. Local Scalars .. + DOUBLE PRECISION DSDOT + INTEGER I,KX,KY,NS +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. + DSDOT = SB + IF (N.LE.0) THEN + SDSDOT = REAL(DSDOT) + RETURN + END IF + IF (INCX.EQ.INCY .AND. INCX.GT.0) THEN +* +* Code for equal and positive increments. +* + NS = N*INCX + DO I = 1,NS,INCX + DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I)) + END DO + ELSE +* +* Code for unequal or nonpositive increments. +* + KX = 1 + KY = 1 + IF (INCX.LT.0) KX = 1 + (1-N)*INCX + IF (INCY.LT.0) KY = 1 + (1-N)*INCY + DO I = 1,N + DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY)) + KX = KX + INCX + KY = KY + INCY + END DO + END IF + SDSDOT = REAL(DSDOT) + RETURN +* +* End of SDSDOT +* + END diff --git a/src/sgbmv.c b/src/sgbmv.c new file mode 100644 index 0000000..b5211ee --- /dev/null +++ b/src/sgbmv.c @@ -0,0 +1,367 @@ +*> \brief \b SGBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER INCX,INCY,KL,KU,LDA,M,N +* CHARACTER TRANS +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SGBMV 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 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**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] 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 REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL 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 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, 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 +*> +* ===================================================================== + SUBROUTINE SGBMV(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 .. + REAL ALPHA,BETA + INTEGER INCX,INCY,KL,KU,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + REAL A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,K,KUP1,KX,KY,LENX,LENY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC 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('SGBMV ',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 +* +* 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. +* + JY = KY + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = ZERO + K = KUP1 - J + DO 90 I = MAX(1,J-KU),MIN(M,J+KL) + TEMP = TEMP + A(K+I,J)*X(I) + 90 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 100 CONTINUE + ELSE + DO 120 J = 1,N + TEMP = ZERO + IX = KX + K = KUP1 - J + DO 110 I = MAX(1,J-KU),MIN(M,J+KL) + TEMP = TEMP + A(K+I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + IF (J.GT.KU) KX = KX + INCX + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of SGBMV +* + END diff --git a/src/sgemm.c b/src/sgemm.c new file mode 100644 index 0000000..d25a152 --- /dev/null +++ b/src/sgemm.c @@ -0,0 +1,379 @@ +*> \brief \b SGEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,M,N +* CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. +* REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SGEMM performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \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] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix +*> op( A ) and of the matrix C. 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 +*> op( B ) and the number of columns of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \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, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is m otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading m by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \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 TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is REAL array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \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 TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is REAL +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \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, 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 +*> +* ===================================================================== + SUBROUTINE SGEMM(TRANSA,TRANSB,M,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 .. + REAL ALPHA,BETA + INTEGER K,LDA,LDB,LDC,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,J,L,NROWA,NROWB + LOGICAL NOTA,NOTB +* .. +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* transposed and set NROWA and NROWB as the number of rows of A +* and B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + IF (NOTA) THEN + NROWA = M + ELSE + NROWA = K + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SGEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And if 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 (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 50 I = 1,M + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = 1,M + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 120 J = 1,N + DO 110 I = 1,M + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF (NOTA) THEN +* +* Form C := alpha*A*B**T + beta*C +* + DO 170 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 130 I = 1,M + C(I,J) = ZERO + 130 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 140 I = 1,M + C(I,J) = BETA*C(I,J) + 140 CONTINUE + END IF + DO 160 L = 1,K + TEMP = ALPHA*B(J,L) + DO 150 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 200 J = 1,N + DO 190 I = 1,M + TEMP = ZERO + DO 180 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 180 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* End of SGEMM +* + END diff --git a/src/sgemv.c b/src/sgemv.c new file mode 100644 index 0000000..0517b12 --- /dev/null +++ b/src/sgemv.c @@ -0,0 +1,327 @@ +*> \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 +*> +* ===================================================================== + SUBROUTINE SGEMV(TRANS,M,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 .. + REAL ALPHA,BETA + INTEGER INCX,INCY,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + REAL A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* 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 (LDA.LT.MAX(1,M)) 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('SGEMV ',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 +* +* 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 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 + 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) + DO 50 I = 1,M + Y(I) = Y(I) + TEMP*A(I,J) + 50 CONTINUE + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80 J = 1,N + TEMP = ALPHA*X(JX) + IY = KY + DO 70 I = 1,M + Y(IY) = Y(IY) + TEMP*A(I,J) + IY = IY + INCY + 70 CONTINUE + JX = JX + INCX + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A**T*x + y. +* + JY = KY + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = ZERO + DO 90 I = 1,M + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 100 CONTINUE + ELSE + DO 120 J = 1,N + TEMP = ZERO + IX = KX + DO 110 I = 1,M + TEMP = TEMP + A(I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of SGEMV +* + END diff --git a/src/sger.c b/src/sger.c new file mode 100644 index 0000000..9dfe4a2 --- /dev/null +++ b/src/sger.c @@ -0,0 +1,224 @@ +*> \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 +*> +* ===================================================================== + SUBROUTINE SGER(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 .. + REAL ALPHA + INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. + REAL A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL 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('SGER ',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 SGER +* + END diff --git a/src/snrm2.c b/src/snrm2.c new file mode 100644 index 0000000..1ea1a47 --- /dev/null +++ b/src/snrm2.c @@ -0,0 +1,199 @@ +!> \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 +!> +! ===================================================================== +function SNRM2( n, x, incx ) + integer, parameter :: wp = kind(1.e0) + real(wp) :: SNRM2 +! +! -- 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 .. + real(wp), parameter :: zero = 0.0_wp + real(wp), parameter :: one = 1.0_wp + real(wp), parameter :: maxN = huge(0.0_wp) +! .. +! .. Blue's scaling constants .. + real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( & + (minexponent(0._wp) - 1) * 0.5_wp) + real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( & + (maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp) + real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( & + (minexponent(0._wp) - digits(0._wp)) * 0.5_wp)) + real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( & + (maxexponent(0._wp) + digits(0._wp) - 1) * 0.5_wp)) +! .. +! .. Scalar Arguments .. + integer :: incx, n +! .. +! .. Array Arguments .. + real(wp) :: x(*) +! .. +! .. Local Scalars .. + integer :: i, ix + logical :: notbig + real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin +! +! Quick return if possible +! + SNRM2 = zero + if( n <= 0 ) return +! + 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 + do i = 1, n + ax = abs(x(ix)) + if (ax > tbig) then + abig = abig + (ax*sbig)**2 + notbig = .false. + else if (ax < tsml) then + if (notbig) asml = asml + (ax*ssml)**2 + else + amed = amed + ax**2 + end if + ix = ix + incx + end do +! +! Combine abig and amed or amed and asml if more than one +! accumulator was used. +! + if (abig > zero) then +! +! Combine abig and amed if abig > 0. +! + if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then + abig = abig + (amed*sbig)*sbig + end if + scl = one / sbig + sumsq = abig + else if (asml > zero) then +! +! Combine amed and asml if asml > 0. +! + if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then + amed = sqrt(amed) + asml = sqrt(asml) / ssml + if (asml > amed) then + ymin = amed + ymax = asml + else + ymin = asml + ymax = amed + end if + scl = one + sumsq = ymax**2*( one + (ymin/ymax)**2 ) + else + scl = one / ssml + sumsq = asml + end if + else +! +! Otherwise all values are mid-range +! + scl = one + sumsq = amed + end if + SNRM2 = scl*sqrt( sumsq ) + return +end function diff --git a/src/srot.c b/src/srot.c new file mode 100644 index 0000000..1441e0d --- /dev/null +++ b/src/srot.c @@ -0,0 +1,142 @@ +*> \brief \b SROT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SROT(N,SX,INCX,SY,INCY,C,S) +* +* .. Scalar Arguments .. +* REAL C,S +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* REAL SX(*),SY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> applies a plane rotation. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \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 +*> +*> \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 +*> +*> \param[in] C +*> \verbatim +*> C is REAL +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is REAL +*> \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 +*> +* ===================================================================== + SUBROUTINE SROT(N,SX,INCX,SY,INCY,C,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 .. + REAL C,S + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + REAL SX(*),SY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL STEMP + INTEGER I,IX,IY +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + STEMP = C*SX(I) + S*SY(I) + SY(I) = C*SY(I) - S*SX(I) + SX(I) = STEMP + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + STEMP = C*SX(IX) + S*SY(IY) + SY(IY) = C*SY(IY) - S*SX(IX) + SX(IX) = STEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of SROT +* + END diff --git a/src/srotg.c b/src/srotg.c new file mode 100644 index 0000000..af1bece --- /dev/null +++ b/src/srotg.c @@ -0,0 +1,151 @@ +!> \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 +! +! ===================================================================== +subroutine SROTG( 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 +! .. +! .. 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 & + ) +! .. +! .. Scalar Arguments .. + real(wp) :: a, b, c, s +! .. +! .. Local Scalars .. + real(wp) :: anorm, bnorm, scl, sigma, r, z +! .. + anorm = abs(a) + bnorm = abs(b) + if( bnorm == zero ) then + c = one + s = zero + b = zero + else if( anorm == zero ) then + c = zero + s = one + a = b + b = one + else + scl = min( safmax, max( safmin, anorm, bnorm ) ) + if( anorm > bnorm ) then + sigma = sign(one,a) + else + sigma = sign(one,b) + end if + r = sigma*( scl*sqrt((a/scl)**2 + (b/scl)**2) ) + c = a/r + s = b/r + if( anorm > bnorm ) then + z = s + else if( c /= zero ) then + z = one/c + else + z = one + end if + a = r + b = z + end if + return +end subroutine diff --git a/src/srotm.c b/src/srotm.c new file mode 100644 index 0000000..a20cfd9 --- /dev/null +++ b/src/srotm.c @@ -0,0 +1,201 @@ +*> \brief \b SROTM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SROTM(N,SX,INCX,SY,INCY,SPARAM) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* REAL SPARAM(5),SX(*),SY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX +*> +*> (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN +*> (SX**T) +*> +*> SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE +*> LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY. +*> WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. +*> +*> SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 +*> +*> (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) +*> H=( ) ( ) ( ) ( ) +*> (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). +*> SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \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 +*> +*> \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 +*> +*> \param[in] SPARAM +*> \verbatim +*> SPARAM is REAL array, dimension (5) +*> SPARAM(1)=SFLAG +*> SPARAM(2)=SH11 +*> SPARAM(3)=SH21 +*> SPARAM(4)=SH12 +*> SPARAM(5)=SH22 +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_blas_level1 +* +* ===================================================================== + SUBROUTINE SROTM(N,SX,INCX,SY,INCY,SPARAM) +* +* -- 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 INCX,INCY,N +* .. +* .. Array Arguments .. + REAL SPARAM(5),SX(*),SY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL SFLAG,SH11,SH12,SH21,SH22,TWO,W,Z,ZERO + INTEGER I,KX,KY,NSTEPS +* .. +* .. Data statements .. + DATA ZERO,TWO/0.E0,2.E0/ +* .. +* + SFLAG = SPARAM(1) + IF (N.LE.0 .OR. (SFLAG+TWO.EQ.ZERO)) RETURN + IF (INCX.EQ.INCY.AND.INCX.GT.0) THEN +* + NSTEPS = N*INCX + IF (SFLAG.LT.ZERO) THEN + SH11 = SPARAM(2) + SH12 = SPARAM(4) + SH21 = SPARAM(3) + SH22 = SPARAM(5) + DO I = 1,NSTEPS,INCX + W = SX(I) + Z = SY(I) + SX(I) = W*SH11 + Z*SH12 + SY(I) = W*SH21 + Z*SH22 + END DO + ELSE IF (SFLAG.EQ.ZERO) THEN + SH12 = SPARAM(4) + SH21 = SPARAM(3) + DO I = 1,NSTEPS,INCX + W = SX(I) + Z = SY(I) + SX(I) = W + Z*SH12 + SY(I) = W*SH21 + Z + END DO + ELSE + SH11 = SPARAM(2) + SH22 = SPARAM(5) + DO I = 1,NSTEPS,INCX + W = SX(I) + Z = SY(I) + SX(I) = W*SH11 + Z + SY(I) = -W + SH22*Z + END DO + END IF + ELSE + KX = 1 + KY = 1 + IF (INCX.LT.0) KX = 1 + (1-N)*INCX + IF (INCY.LT.0) KY = 1 + (1-N)*INCY +* + IF (SFLAG.LT.ZERO) THEN + SH11 = SPARAM(2) + SH12 = SPARAM(4) + SH21 = SPARAM(3) + SH22 = SPARAM(5) + DO I = 1,N + W = SX(KX) + Z = SY(KY) + SX(KX) = W*SH11 + Z*SH12 + SY(KY) = W*SH21 + Z*SH22 + KX = KX + INCX + KY = KY + INCY + END DO + ELSE IF (SFLAG.EQ.ZERO) THEN + SH12 = SPARAM(4) + SH21 = SPARAM(3) + DO I = 1,N + W = SX(KX) + Z = SY(KY) + SX(KX) = W + Z*SH12 + SY(KY) = W*SH21 + Z + KX = KX + INCX + KY = KY + INCY + END DO + ELSE + SH11 = SPARAM(2) + SH22 = SPARAM(5) + DO I = 1,N + W = SX(KX) + Z = SY(KY) + SX(KX) = W*SH11 + Z + SY(KY) = -W + SH22*Z + KX = KX + INCX + KY = KY + INCY + END DO + END IF + END IF + RETURN +* +* End of SROTM +* + END diff --git a/src/srotmg.c b/src/srotmg.c new file mode 100644 index 0000000..63d55dd --- /dev/null +++ b/src/srotmg.c @@ -0,0 +1,260 @@ +*> \brief \b SROTMG +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM) +* +* .. Scalar Arguments .. +* REAL SD1,SD2,SX1,SY1 +* .. +* .. Array Arguments .. +* REAL SPARAM(5) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS +*> THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)*> SY2)**T. +*> WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. +*> +*> SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 +*> +*> (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) +*> H=( ) ( ) ( ) ( ) +*> (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). +*> LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22 +*> RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE +*> VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.) +*> +*> THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE +*> INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE +*> OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in,out] SD1 +*> \verbatim +*> SD1 is REAL +*> \endverbatim +*> +*> \param[in,out] SD2 +*> \verbatim +*> SD2 is REAL +*> \endverbatim +*> +*> \param[in,out] SX1 +*> \verbatim +*> SX1 is REAL +*> \endverbatim +*> +*> \param[in] SY1 +*> \verbatim +*> SY1 is REAL +*> \endverbatim +*> +*> \param[out] SPARAM +*> \verbatim +*> SPARAM is REAL array, dimension (5) +*> SPARAM(1)=SFLAG +*> SPARAM(2)=SH11 +*> SPARAM(3)=SH21 +*> SPARAM(4)=SH12 +*> SPARAM(5)=SH22 +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_blas_level1 +* +* ===================================================================== + SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM) +* +* -- 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 .. + REAL SD1,SD2,SX1,SY1 +* .. +* .. Array Arguments .. + REAL SPARAM(5) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL GAM,GAMSQ,ONE,RGAMSQ,SFLAG,SH11,SH12,SH21,SH22,SP1,SP2,SQ1, + $ SQ2,STEMP,SU,TWO,ZERO +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Data statements .. +* + DATA ZERO,ONE,TWO/0.E0,1.E0,2.E0/ + DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/ +* .. + + IF (SD1.LT.ZERO) THEN +* GO ZERO-H-D-AND-SX1.. + SFLAG = -ONE + SH11 = ZERO + SH12 = ZERO + SH21 = ZERO + SH22 = ZERO +* + SD1 = ZERO + SD2 = ZERO + SX1 = ZERO + ELSE +* CASE-SD1-NONNEGATIVE + SP2 = SD2*SY1 + IF (SP2.EQ.ZERO) THEN + SFLAG = -TWO + SPARAM(1) = SFLAG + RETURN + END IF +* REGULAR-CASE.. + SP1 = SD1*SX1 + SQ2 = SP2*SY1 + SQ1 = SP1*SX1 +* + IF (ABS(SQ1).GT.ABS(SQ2)) THEN + SH21 = -SY1/SX1 + SH12 = SP2/SP1 +* + SU = ONE - SH12*SH21 +* + IF (SU.GT.ZERO) THEN + SFLAG = ZERO + SD1 = SD1/SU + SD2 = SD2/SU + SX1 = SX1*SU + ELSE +* This code path if here for safety. We do not expect this +* condition to ever hold except in edge cases with rounding +* errors. See DOI: 10.1145/355841.355847 + SFLAG = -ONE + SH11 = ZERO + SH12 = ZERO + SH21 = ZERO + SH22 = ZERO +* + SD1 = ZERO + SD2 = ZERO + SX1 = ZERO + END IF + ELSE + + IF (SQ2.LT.ZERO) THEN +* GO ZERO-H-D-AND-SX1.. + SFLAG = -ONE + SH11 = ZERO + SH12 = ZERO + SH21 = ZERO + SH22 = ZERO +* + SD1 = ZERO + SD2 = ZERO + SX1 = ZERO + ELSE + SFLAG = ONE + SH11 = SP1/SP2 + SH22 = SX1/SY1 + SU = ONE + SH11*SH22 + STEMP = SD2/SU + SD2 = SD1/SU + SD1 = STEMP + SX1 = SY1*SU + END IF + END IF + +* PROCEDURE..SCALE-CHECK + IF (SD1.NE.ZERO) THEN + DO WHILE ((SD1.LE.RGAMSQ) .OR. (SD1.GE.GAMSQ)) + IF (SFLAG.EQ.ZERO) THEN + SH11 = ONE + SH22 = ONE + SFLAG = -ONE + ELSE + SH21 = -ONE + SH12 = ONE + SFLAG = -ONE + END IF + IF (SD1.LE.RGAMSQ) THEN + SD1 = SD1*GAM**2 + SX1 = SX1/GAM + SH11 = SH11/GAM + SH12 = SH12/GAM + ELSE + SD1 = SD1/GAM**2 + SX1 = SX1*GAM + SH11 = SH11*GAM + SH12 = SH12*GAM + END IF + ENDDO + END IF + + IF (SD2.NE.ZERO) THEN + DO WHILE ( (ABS(SD2).LE.RGAMSQ) .OR. (ABS(SD2).GE.GAMSQ) ) + IF (SFLAG.EQ.ZERO) THEN + SH11 = ONE + SH22 = ONE + SFLAG = -ONE + ELSE + SH21 = -ONE + SH12 = ONE + SFLAG = -ONE + END IF + IF (ABS(SD2).LE.RGAMSQ) THEN + SD2 = SD2*GAM**2 + SH21 = SH21/GAM + SH22 = SH22/GAM + ELSE + SD2 = SD2/GAM**2 + SH21 = SH21*GAM + SH22 = SH22*GAM + END IF + END DO + END IF + + END IF + + IF (SFLAG.LT.ZERO) THEN + SPARAM(2) = SH11 + SPARAM(3) = SH21 + SPARAM(4) = SH12 + SPARAM(5) = SH22 + ELSE IF (SFLAG.EQ.ZERO) THEN + SPARAM(3) = SH21 + SPARAM(4) = SH12 + ELSE + SPARAM(2) = SH11 + SPARAM(5) = SH22 + END IF + + SPARAM(1) = SFLAG + RETURN +* +* End of SROTMG +* + END diff --git a/src/ssbmv.c b/src/ssbmv.c new file mode 100644 index 0000000..c458131 --- /dev/null +++ b/src/ssbmv.c @@ -0,0 +1,372 @@ +*> \brief \b SSBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER INCX,INCY,K,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSBMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n symmetric band matrix, with k super-diagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the band matrix A is being supplied as +*> follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> being supplied. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> being supplied. +*> \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, K specifies the number of super-diagonals of the +*> matrix A. K must satisfy 0 .le. K. +*> \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 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 symmetric matrix, 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 the upper +*> triangular part of a symmetric 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 symmetric matrix, 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 the lower +*> triangular part of a symmetric 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 +*> \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] X +*> \verbatim +*> X is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> 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. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is REAL array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> 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 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 +*> +* ===================================================================== + SUBROUTINE SSBMV(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 .. + REAL ALPHA,BETA + INTEGER INCX,INCY,K,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL 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 MAX,MIN +* .. +* +* 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('SSBMV ',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 + A(L+I,J)*X(I) + 50 CONTINUE + Y(J) = Y(J) + TEMP1*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 + A(L+I,J)*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*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*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 + 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*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 + 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 SSBMV +* + END diff --git a/src/sscal.c b/src/sscal.c new file mode 100644 index 0000000..44d0437 --- /dev/null +++ b/src/sscal.c @@ -0,0 +1,140 @@ +*> \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 +*> +* ===================================================================== + SUBROUTINE SSCAL(N,SA,SX,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..-- +* +* .. Scalar Arguments .. + REAL SA + INTEGER INCX,N +* .. +* .. Array Arguments .. + REAL SX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,M,MP1,NINCX +* .. +* .. Parameters .. + REAL ONE + PARAMETER (ONE=1.0E+0) +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0 .OR. INCX.LE.0 .OR. SA.EQ.ONE) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* +* +* clean-up loop +* + M = MOD(N,5) + IF (M.NE.0) THEN + DO I = 1,M + SX(I) = SA*SX(I) + END DO + IF (N.LT.5) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,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) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + SX(I) = SA*SX(I) + END DO + END IF + RETURN +* +* End of SSCAL +* + END diff --git a/src/sspmv.c b/src/sspmv.c new file mode 100644 index 0000000..840fd5c --- /dev/null +++ b/src/sspmv.c @@ -0,0 +1,328 @@ +*> \brief \b SSPMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER INCX,INCY,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* REAL AP(*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSPMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n symmetric matrix, 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] AP +*> \verbatim +*> AP is REAL 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 symmetric 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 symmetric 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. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> 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. +*> \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 + ( 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 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 +*> +* ===================================================================== + SUBROUTINE SSPMV(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 .. + REAL ALPHA,BETA + INTEGER INCX,INCY,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + REAL AP(*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* 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('SSPMV ',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 + AP(K)*X(I) + K = K + 1 + 50 CONTINUE + Y(J) = Y(J) + TEMP1*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 + AP(K)*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*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*AP(KK) + K = KK + 1 + DO 90 I = J + 1,N + Y(I) = Y(I) + TEMP1*AP(K) + TEMP2 = TEMP2 + 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*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 + 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 SSPMV +* + END diff --git a/src/sspr.c b/src/sspr.c new file mode 100644 index 0000000..ab24d3f --- /dev/null +++ b/src/sspr.c @@ -0,0 +1,258 @@ +*> \brief \b SSPR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSPR(UPLO,N,ALPHA,X,INCX,AP) +* +* .. Scalar Arguments .. +* REAL ALPHA +* INTEGER INCX,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* REAL AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSPR performs the symmetric rank 1 operation +*> +*> A := alpha*x*x**T + A, +*> +*> where alpha is a real scalar, x is an n element vector and A is an +*> n by n symmetric 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 REAL 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 REAL 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 symmetric 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 symmetric 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. +*> \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 +*> +* ===================================================================== + SUBROUTINE SSPR(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 .. + REAL AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* 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('SSPR ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.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*X(J) + K = KK + DO 10 I = 1,J + AP(K) = AP(K) + X(I)*TEMP + K = K + 1 + 10 CONTINUE + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*X(JX) + IX = KX + DO 30 K = KK,KK + J - 1 + AP(K) = AP(K) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + 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*X(J) + K = KK + DO 50 I = J,N + AP(K) = AP(K) + X(I)*TEMP + 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 + TEMP = ALPHA*X(JX) + IX = JX + DO 70 K = KK,KK + N - J + AP(K) = AP(K) + X(IX)*TEMP + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of SSPR +* + END diff --git a/src/sspr2.c b/src/sspr2.c new file mode 100644 index 0000000..1107a8c --- /dev/null +++ b/src/sspr2.c @@ -0,0 +1,293 @@ +*> \brief \b SSPR2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) +* +* .. Scalar Arguments .. +* REAL ALPHA +* INTEGER INCX,INCY,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* REAL AP(*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSPR2 performs the symmetric rank 2 operation +*> +*> A := alpha*x*y**T + alpha*y*x**T + A, +*> +*> where alpha is a scalar, x and y are n element vectors and A is an +*> n by n symmetric 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 REAL 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 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] AP +*> \verbatim +*> AP is REAL 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 symmetric 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 symmetric 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. +*> \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 +*> +* ===================================================================== + SUBROUTINE SSPR2(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 .. + REAL ALPHA + INTEGER INCX,INCY,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + REAL AP(*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP1,TEMP2 + INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* 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('SSPR2 ',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*Y(J) + TEMP2 = ALPHA*X(J) + K = KK + DO 10 I = 1,J + AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2 + K = K + 1 + 10 CONTINUE + 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*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = KX + IY = KY + DO 30 K = KK,KK + J - 1 + AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + 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*Y(J) + TEMP2 = ALPHA*X(J) + K = KK + DO 50 I = J,N + AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2 + K = K + 1 + 50 CONTINUE + 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*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = JX + IY = JY + DO 70 K = KK,KK + N - J + AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of SSPR2 +* + END diff --git a/src/sswap.c b/src/sswap.c new file mode 100644 index 0000000..1a0fd9a --- /dev/null +++ b/src/sswap.c @@ -0,0 +1,153 @@ +*> \brief \b SSWAP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSWAP(N,SX,INCX,SY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* REAL SX(*),SY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSWAP interchanges two vectors. +*> 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,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 +*> +*> \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 +*> +* ===================================================================== + SUBROUTINE SSWAP(N,SX,INCX,SY,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + REAL SX(*),SY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + REAL STEMP + INTEGER I,IX,IY,M,MP1 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* +* +* clean-up loop +* + M = MOD(N,3) + IF (M.NE.0) THEN + DO I = 1,M + STEMP = SX(I) + SX(I) = SY(I) + SY(I) = STEMP + END DO + IF (N.LT.3) RETURN + END IF + MP1 = M + 1 + DO I = MP1,N,3 + STEMP = SX(I) + SX(I) = SY(I) + SY(I) = STEMP + STEMP = SX(I+1) + SX(I+1) = SY(I+1) + SY(I+1) = STEMP + STEMP = SX(I+2) + SX(I+2) = SY(I+2) + SY(I+2) = STEMP + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + STEMP = SX(IX) + SX(IX) = SY(IY) + SY(IY) = STEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of SSWAP +* + END diff --git a/src/ssymm.c b/src/ssymm.c new file mode 100644 index 0000000..3147bd6 --- /dev/null +++ b/src/ssymm.c @@ -0,0 +1,364 @@ +*> \brief \b SSYMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER LDA,LDB,LDC,M,N +* CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYMM performs one of the matrix-matrix operations +*> +*> C := alpha*A*B + beta*C, +*> +*> or +*> +*> C := alpha*B*A + beta*C, +*> +*> where alpha and beta are scalars, A is a symmetric matrix and B and +*> C are m by n matrices. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether the symmetric matrix A +*> appears on the left or right in the operation as follows: +*> +*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C, +*> +*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C, +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the symmetric matrix A is to be +*> referenced as follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of the +*> symmetric matrix is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of the +*> symmetric matrix is to be referenced. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix C. +*> 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 C. +*> 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, ka ), where ka is +*> m when SIDE = 'L' or 'l' and is n otherwise. +*> Before entry with SIDE = 'L' or 'l', the m by m part of +*> the array A must contain the symmetric matrix, such that +*> when UPLO = 'U' or 'u', the leading m by m upper triangular +*> part of the array A must contain the upper triangular part +*> of the symmetric matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading m by m lower triangular part of the array A +*> must contain the lower triangular part of the symmetric +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> Before entry with SIDE = 'R' or 'r', the n by n part of +*> the array A must contain the symmetric matrix, such that +*> when UPLO = 'U' or 'u', the leading n by n upper triangular +*> part of the array A must contain the upper triangular part +*> of the symmetric matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading n by n lower triangular part of the array A +*> must contain the lower triangular part of the symmetric +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> \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 ), otherwise LDA must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is REAL array, dimension ( LDB, N ) +*> Before entry, the leading m 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. LDB must be at least +*> max( 1, m ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is REAL +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n updated +*> matrix. +*> \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, 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 +*> +* ===================================================================== + SUBROUTINE SSYMM(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 .. + REAL ALPHA,BETA + INTEGER LDA,LDB,LDC,M,N + CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + REAL TEMP1,TEMP2 + INTEGER I,INFO,J,K,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=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('SSYMM ',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 SSYMM +* + END diff --git a/src/ssymv.c b/src/ssymv.c new file mode 100644 index 0000000..9111798 --- /dev/null +++ b/src/ssymv.c @@ -0,0 +1,330 @@ +*> \brief \b SSYMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER INCX,INCY,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYMV performs the matrix-vector operation +*> +*> y := alpha*A*x + beta*y, +*> +*> where alpha and beta are scalars, x and y are n element vectors and +*> A is an n by n symmetric matrix. +*> \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] A +*> \verbatim +*> 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 part of the symmetric matrix and the strictly +*> lower triangular part of A is not referenced. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of A is not referenced. +*> \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 REAL 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 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 + ( 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 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 +*> +* ===================================================================== + SUBROUTINE SSYMV(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 .. + REAL ALPHA,BETA + INTEGER INCX,INCY,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL 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 MAX +* .. +* +* 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('SSYMV ',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 + A(I,J)*X(I) + 50 CONTINUE + Y(J) = Y(J) + TEMP1*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 + A(I,J)*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*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*A(J,J) + DO 90 I = J + 1,N + Y(I) = Y(I) + TEMP1*A(I,J) + TEMP2 = TEMP2 + 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*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 + 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 SSYMV +* + END diff --git a/src/ssyr.c b/src/ssyr.c new file mode 100644 index 0000000..51164c5 --- /dev/null +++ b/src/ssyr.c @@ -0,0 +1,260 @@ +*> \brief \b SSYR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSYR(UPLO,N,ALPHA,X,INCX,A,LDA) +* +* .. Scalar Arguments .. +* REAL ALPHA +* INTEGER INCX,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYR performs the symmetric rank 1 operation +*> +*> A := alpha*x*x**T + A, +*> +*> where alpha is a real scalar, x is an n element vector and A is an +*> n by n symmetric 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 REAL 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 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 part of the symmetric matrix and the strictly +*> lower triangular part of A is not referenced. On exit, the +*> upper triangular part of the array A is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of A is not referenced. On exit, the +*> lower triangular part of the array A is overwritten by the +*> lower triangular part of the updated matrix. +*> \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 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 +*> +* ===================================================================== + SUBROUTINE SSYR(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 .. + REAL A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,J,JX,KX +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* +* 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('SSYR ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.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*X(J) + DO 10 I = 1,J + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*X(JX) + IX = KX + DO 30 I = 1,J + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 30 CONTINUE + 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*X(J) + DO 50 I = J,N + A(I,J) = A(I,J) + X(I)*TEMP + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*X(JX) + IX = JX + DO 70 I = J,N + A(I,J) = A(I,J) + X(IX)*TEMP + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of SSYR +* + END diff --git a/src/ssyr2.c b/src/ssyr2.c new file mode 100644 index 0000000..1dc73ee --- /dev/null +++ b/src/ssyr2.c @@ -0,0 +1,295 @@ +*> \brief \b SSYR2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* REAL ALPHA +* INTEGER INCX,INCY,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYR2 performs the symmetric rank 2 operation +*> +*> A := alpha*x*y**T + alpha*y*x**T + A, +*> +*> where alpha is a scalar, x and y are n element vectors and A is an n +*> by n symmetric 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 REAL 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 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 with UPLO = 'U' or 'u', the leading n by n +*> upper triangular part of the array A must contain the upper +*> triangular part of the symmetric matrix and the strictly +*> lower triangular part of A is not referenced. On exit, the +*> upper triangular part of the array A is overwritten by the +*> upper triangular part of the updated matrix. +*> Before entry with UPLO = 'L' or 'l', the leading n by n +*> lower triangular part of the array A must contain the lower +*> triangular part of the symmetric matrix and the strictly +*> upper triangular part of A is not referenced. On exit, the +*> lower triangular part of the array A is overwritten by the +*> lower triangular part of the updated matrix. +*> \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 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 +*> +* ===================================================================== + SUBROUTINE SSYR2(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 .. + REAL ALPHA + INTEGER INCX,INCY,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL 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 MAX +* .. +* +* 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('SSYR2 ',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*Y(J) + TEMP2 = ALPHA*X(J) + DO 10 I = 1,J + A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + DO 40 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = KX + IY = KY + DO 30 I = 1,J + A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + 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*Y(J) + TEMP2 = ALPHA*X(J) + DO 50 I = J,N + A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2 + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + DO 80 J = 1,N + IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = JX + IY = JY + DO 70 I = J,N + A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of SSYR2 +* + END diff --git a/src/ssyr2k.c b/src/ssyr2k.c new file mode 100644 index 0000000..1bb5aa4 --- /dev/null +++ b/src/ssyr2k.c @@ -0,0 +1,396 @@ +*> \brief \b SSYR2K +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYR2K 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. +*> +*> TRANS = 'C' or 'c' 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' or '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 REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL 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 REAL 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 REAL 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 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 +*> +* ===================================================================== + SUBROUTINE SSYR2K(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 .. + REAL ALPHA,BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + REAL TEMP1,TEMP2 + 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,'T')) .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('SSYR2K',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 SSYR2K +* + END diff --git a/src/ssyrk.c b/src/ssyrk.c new file mode 100644 index 0000000..faca01b --- /dev/null +++ b/src/ssyrk.c @@ -0,0 +1,361 @@ +*> \brief \b SSYRK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSYRK(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 .. +* REAL A(LDA,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSYRK 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. +*> +*> TRANS = 'C' or 'c' 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' or '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 REAL 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 REAL 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 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 +*> +* ===================================================================== + SUBROUTINE SSYRK(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 .. + REAL A(LDA,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + REAL TEMP + 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,'T')) .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('SSYRK ',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 SSYRK +* + END diff --git a/src/stbmv.c b/src/stbmv.c new file mode 100644 index 0000000..09273a1 --- /dev/null +++ b/src/stbmv.c @@ -0,0 +1,395 @@ +*> \brief \b STBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE STBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,K,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> STBMV performs one of the matrix-vector operations +*> +*> 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 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**T*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 REAL 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 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 +*> 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 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 +*> +* ===================================================================== + SUBROUTINE STBMV(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 .. + REAL A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC 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('STBMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + 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. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 100 J = N,1,-1 + TEMP = X(J) + L = KPLUS1 - J + 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 + X(J) = TEMP + 100 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 120 J = N,1,-1 + TEMP = X(JX) + KX = KX - INCX + IX = KX + L = KPLUS1 - J + IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J) + DO 110 I = J - 1,MAX(1,J-K),-1 + TEMP = TEMP + A(L+I,J)*X(IX) + IX = IX - INCX + 110 CONTINUE + X(JX) = TEMP + JX = JX - INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = 1,N + TEMP = X(J) + L = 1 - J + IF (NOUNIT) TEMP = TEMP*A(1,J) + DO 130 I = J + 1,MIN(N,J+K) + TEMP = TEMP + A(L+I,J)*X(I) + 130 CONTINUE + X(J) = TEMP + 140 CONTINUE + ELSE + JX = KX + DO 160 J = 1,N + TEMP = X(JX) + KX = KX + INCX + IX = KX + L = 1 - J + IF (NOUNIT) TEMP = TEMP*A(1,J) + DO 150 I = J + 1,MIN(N,J+K) + TEMP = TEMP + A(L+I,J)*X(IX) + IX = IX + INCX + 150 CONTINUE + X(JX) = TEMP + JX = JX + INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of STBMV +* + END diff --git a/src/stbsv.c b/src/stbsv.c new file mode 100644 index 0000000..5f37cf7 --- /dev/null +++ b/src/stbsv.c @@ -0,0 +1,398 @@ +*> \brief \b STBSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE STBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,K,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> STBSV solves one of the systems of equations +*> +*> A*x = b, or A**T*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**T*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 REAL 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 REAL 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 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 +*> +* ===================================================================== + SUBROUTINE STBSV(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 .. + REAL A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC 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('STBSV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + 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. +* + IF (LSAME(UPLO,'U')) THEN + KPLUS1 = K + 1 + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = X(J) + L = KPLUS1 - J + 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) + X(J) = TEMP + 100 CONTINUE + ELSE + JX = KX + DO 120 J = 1,N + TEMP = X(JX) + IX = KX + L = KPLUS1 - J + DO 110 I = MAX(1,J-K),J - 1 + TEMP = TEMP - A(L+I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) + X(JX) = TEMP + JX = JX + INCX + IF (J.GT.K) KX = KX + INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = N,1,-1 + TEMP = X(J) + L = 1 - J + DO 130 I = MIN(N,J+K),J + 1,-1 + TEMP = TEMP - A(L+I,J)*X(I) + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(1,J) + X(J) = TEMP + 140 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 160 J = N,1,-1 + TEMP = X(JX) + IX = KX + L = 1 - J + DO 150 I = MIN(N,J+K),J + 1,-1 + TEMP = TEMP - A(L+I,J)*X(IX) + IX = IX - INCX + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(1,J) + X(JX) = TEMP + JX = JX - INCX + IF ((N-J).GE.K) KX = KX - INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of STBSV +* + END diff --git a/src/stpmv.c b/src/stpmv.c new file mode 100644 index 0000000..9e77c1e --- /dev/null +++ b/src/stpmv.c @@ -0,0 +1,349 @@ +*> \brief \b STPMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE STPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* REAL AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> STPMV performs one of the matrix-vector operations +*> +*> 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, 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**T*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 REAL 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 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 +*> 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 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 +*> +* ===================================================================== + SUBROUTINE STPMV(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 .. + REAL AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* 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('STPMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + 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. +* + IF (LSAME(UPLO,'U')) THEN + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 100 J = N,1,-1 + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*AP(KK) + K = KK - 1 + DO 90 I = J - 1,1,-1 + TEMP = TEMP + AP(K)*X(I) + K = K - 1 + 90 CONTINUE + X(J) = TEMP + KK = KK - J + 100 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 120 J = N,1,-1 + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*AP(KK) + DO 110 K = KK - 1,KK - J + 1,-1 + IX = IX - INCX + TEMP = TEMP + AP(K)*X(IX) + 110 CONTINUE + X(JX) = TEMP + JX = JX - INCX + KK = KK - J + 120 CONTINUE + END IF + ELSE + KK = 1 + IF (INCX.EQ.1) THEN + DO 140 J = 1,N + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*AP(KK) + K = KK + 1 + DO 130 I = J + 1,N + TEMP = TEMP + AP(K)*X(I) + K = K + 1 + 130 CONTINUE + X(J) = TEMP + KK = KK + (N-J+1) + 140 CONTINUE + ELSE + JX = KX + DO 160 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*AP(KK) + DO 150 K = KK + 1,KK + N - J + IX = IX + INCX + TEMP = TEMP + AP(K)*X(IX) + 150 CONTINUE + X(JX) = TEMP + JX = JX + INCX + KK = KK + (N-J+1) + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of STPMV +* + END diff --git a/src/stpsv.c b/src/stpsv.c new file mode 100644 index 0000000..40b1ffb --- /dev/null +++ b/src/stpsv.c @@ -0,0 +1,351 @@ +*> \brief \b STPSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE STPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* REAL AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> STPSV solves one of the systems of equations +*> +*> A*x = b, or A**T*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**T*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 REAL 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 REAL 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 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 +*> +* ===================================================================== + SUBROUTINE STPSV(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 .. + REAL AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* +* 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('STPSV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + 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. +* + IF (LSAME(UPLO,'U')) THEN + KK = 1 + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = X(J) + K = KK + 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) + X(J) = TEMP + KK = KK + J + 100 CONTINUE + ELSE + JX = KX + DO 120 J = 1,N + TEMP = X(JX) + IX = KX + DO 110 K = KK,KK + J - 2 + TEMP = TEMP - AP(K)*X(IX) + IX = IX + INCX + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK+J-1) + X(JX) = TEMP + JX = JX + INCX + KK = KK + J + 120 CONTINUE + END IF + ELSE + KK = (N* (N+1))/2 + IF (INCX.EQ.1) THEN + DO 140 J = N,1,-1 + TEMP = X(J) + K = KK + DO 130 I = N,J + 1,-1 + TEMP = TEMP - AP(K)*X(I) + K = K - 1 + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK-N+J) + X(J) = TEMP + KK = KK - (N-J+1) + 140 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 160 J = N,1,-1 + TEMP = X(JX) + IX = KX + DO 150 K = KK,KK - (N- (J+1)),-1 + TEMP = TEMP - AP(K)*X(IX) + IX = IX - INCX + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/AP(KK-N+J) + X(JX) = TEMP + JX = JX - INCX + KK = KK - (N-J+1) + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of STPSV +* + END diff --git a/src/strmm.c b/src/strmm.c new file mode 100644 index 0000000..9aa2ac2 --- /dev/null +++ b/src/strmm.c @@ -0,0 +1,412 @@ +*> \brief \b STRMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE STRMM(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 +*> +*> STRMM 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. +*> \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**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 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 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 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 +*> +* ===================================================================== + SUBROUTINE STRMM(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 .. + REAL ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOUNIT,UPPER +* .. +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + 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('STRMM ',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. +* + IF (UPPER) THEN + DO 110 J = 1,N + DO 100 I = M,1,-1 + TEMP = B(I,J) + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 90 K = 1,I - 1 + TEMP = TEMP + A(K,I)*B(K,J) + 90 CONTINUE + B(I,J) = ALPHA*TEMP + 100 CONTINUE + 110 CONTINUE + ELSE + DO 140 J = 1,N + DO 130 I = 1,M + TEMP = B(I,J) + IF (NOUNIT) TEMP = TEMP*A(I,I) + DO 120 K = I + 1,M + TEMP = TEMP + A(K,I)*B(K,J) + 120 CONTINUE + B(I,J) = ALPHA*TEMP + 130 CONTINUE + 140 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*A. +* + IF (UPPER) THEN + DO 180 J = N,1,-1 + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = 1,M + B(I,J) = TEMP*B(I,J) + 150 CONTINUE + DO 170 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 160 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + ELSE + DO 220 J = 1,N + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 190 I = 1,M + B(I,J) = TEMP*B(I,J) + 190 CONTINUE + DO 210 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + TEMP = ALPHA*A(K,J) + DO 200 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 200 CONTINUE + END IF + 210 CONTINUE + 220 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*A**T. +* + IF (UPPER) THEN + DO 260 K = 1,N + DO 240 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + TEMP = ALPHA*A(J,K) + DO 230 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 230 CONTINUE + END IF + 240 CONTINUE + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(K,K) + IF (TEMP.NE.ONE) THEN + DO 250 I = 1,M + B(I,K) = TEMP*B(I,K) + 250 CONTINUE + END IF + 260 CONTINUE + ELSE + DO 300 K = N,1,-1 + DO 280 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + TEMP = ALPHA*A(J,K) + DO 270 I = 1,M + B(I,J) = B(I,J) + TEMP*B(I,K) + 270 CONTINUE + END IF + 280 CONTINUE + TEMP = ALPHA + IF (NOUNIT) TEMP = TEMP*A(K,K) + IF (TEMP.NE.ONE) THEN + DO 290 I = 1,M + B(I,K) = TEMP*B(I,K) + 290 CONTINUE + END IF + 300 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of STRMM +* + END diff --git a/src/strmv.c b/src/strmv.c new file mode 100644 index 0000000..6f5a3e8 --- /dev/null +++ b/src/strmv.c @@ -0,0 +1,339 @@ +*> \brief \b STRMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE STRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> STRMV performs one of the matrix-vector operations +*> +*> 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. +*> \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**T*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 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 +*> 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 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 +*> 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 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 +*> +* ===================================================================== + SUBROUTINE STRMV(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 .. + REAL A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC 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('STRMV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + 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 + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 10 I = 1,J - 1 + X(I) = X(I) + TEMP*A(I,J) + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 30 I = 1,J - 1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX + 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) + DO 50 I = N,J + 1,-1 + X(I) = X(I) + TEMP*A(I,J) + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,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 + DO 70 I = N,J + 1,-1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 100 J = N,1,-1 + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 90 I = J - 1,1,-1 + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + X(J) = TEMP + 100 CONTINUE + ELSE + JX = KX + (N-1)*INCX + DO 120 J = N,1,-1 + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 110 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + A(I,J)*X(IX) + 110 CONTINUE + X(JX) = TEMP + JX = JX - INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = 1,N + TEMP = X(J) + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 130 I = J + 1,N + TEMP = TEMP + A(I,J)*X(I) + 130 CONTINUE + X(J) = TEMP + 140 CONTINUE + ELSE + JX = KX + DO 160 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + A(I,J)*X(IX) + 150 CONTINUE + X(JX) = TEMP + JX = JX + INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of STRMV +* + END diff --git a/src/strsm.c b/src/strsm.c new file mode 100644 index 0000000..6e97c52 --- /dev/null +++ b/src/strsm.c @@ -0,0 +1,440 @@ +*> \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 +*> +* ===================================================================== + SUBROUTINE STRSM(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 .. + REAL ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + REAL A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOUNIT,UPPER +* .. +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* +* Test the input parameters. +* + LSIDE = LSAME(SIDE,'L') + IF (LSIDE) THEN + NROWA = M + ELSE + NROWA = N + END IF + 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('STRSM ',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. +* + IF (UPPER) THEN + DO 130 J = 1,N + DO 120 I = 1,M + TEMP = ALPHA*B(I,J) + DO 110 K = 1,I - 1 + TEMP = TEMP - A(K,I)*B(K,J) + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + B(I,J) = TEMP + 120 CONTINUE + 130 CONTINUE + ELSE + DO 160 J = 1,N + DO 150 I = M,1,-1 + TEMP = ALPHA*B(I,J) + DO 140 K = I + 1,M + TEMP = TEMP - A(K,I)*B(K,J) + 140 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(I,I) + B(I,J) = TEMP + 150 CONTINUE + 160 CONTINUE + END IF + END IF + ELSE + IF (LSAME(TRANSA,'N')) THEN +* +* Form B := alpha*B*inv( A ). +* + IF (UPPER) THEN + DO 210 J = 1,N + IF (ALPHA.NE.ONE) THEN + DO 170 I = 1,M + B(I,J) = ALPHA*B(I,J) + 170 CONTINUE + END IF + DO 190 K = 1,J - 1 + IF (A(K,J).NE.ZERO) THEN + DO 180 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 180 CONTINUE + END IF + 190 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 200 I = 1,M + B(I,J) = TEMP*B(I,J) + 200 CONTINUE + END IF + 210 CONTINUE + ELSE + DO 260 J = N,1,-1 + IF (ALPHA.NE.ONE) THEN + DO 220 I = 1,M + B(I,J) = ALPHA*B(I,J) + 220 CONTINUE + END IF + DO 240 K = J + 1,N + IF (A(K,J).NE.ZERO) THEN + DO 230 I = 1,M + B(I,J) = B(I,J) - A(K,J)*B(I,K) + 230 CONTINUE + END IF + 240 CONTINUE + IF (NOUNIT) THEN + TEMP = ONE/A(J,J) + DO 250 I = 1,M + B(I,J) = TEMP*B(I,J) + 250 CONTINUE + END IF + 260 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*inv( A**T ). +* + IF (UPPER) THEN + DO 310 K = N,1,-1 + IF (NOUNIT) THEN + TEMP = ONE/A(K,K) + DO 270 I = 1,M + B(I,K) = TEMP*B(I,K) + 270 CONTINUE + END IF + DO 290 J = 1,K - 1 + IF (A(J,K).NE.ZERO) THEN + TEMP = A(J,K) + DO 280 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 280 CONTINUE + END IF + 290 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 300 I = 1,M + B(I,K) = ALPHA*B(I,K) + 300 CONTINUE + END IF + 310 CONTINUE + ELSE + DO 360 K = 1,N + IF (NOUNIT) THEN + TEMP = ONE/A(K,K) + DO 320 I = 1,M + B(I,K) = TEMP*B(I,K) + 320 CONTINUE + END IF + DO 340 J = K + 1,N + IF (A(J,K).NE.ZERO) THEN + TEMP = A(J,K) + DO 330 I = 1,M + B(I,J) = B(I,J) - TEMP*B(I,K) + 330 CONTINUE + END IF + 340 CONTINUE + IF (ALPHA.NE.ONE) THEN + DO 350 I = 1,M + B(I,K) = ALPHA*B(I,K) + 350 CONTINUE + END IF + 360 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of STRSM +* + END diff --git a/src/strsv.c b/src/strsv.c new file mode 100644 index 0000000..e228ea9 --- /dev/null +++ b/src/strsv.c @@ -0,0 +1,341 @@ +*> \brief \b STRSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE STRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* REAL A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> STRSV solves one of the systems of equations +*> +*> A*x = b, or A**T*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**T*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 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 +*> 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 REAL 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 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 +*> +* ===================================================================== + SUBROUTINE STRSV(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 .. + REAL A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER (ZERO=0.0E+0) +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC 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('STRSV ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF (N.EQ.0) RETURN +* + 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. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 100 J = 1,N + TEMP = X(J) + DO 90 I = 1,J - 1 + TEMP = TEMP - A(I,J)*X(I) + 90 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + X(J) = TEMP + 100 CONTINUE + ELSE + JX = KX + DO 120 J = 1,N + TEMP = X(JX) + IX = KX + DO 110 I = 1,J - 1 + TEMP = TEMP - A(I,J)*X(IX) + IX = IX + INCX + 110 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + X(JX) = TEMP + JX = JX + INCX + 120 CONTINUE + END IF + ELSE + IF (INCX.EQ.1) THEN + DO 140 J = N,1,-1 + TEMP = X(J) + DO 130 I = N,J + 1,-1 + TEMP = TEMP - A(I,J)*X(I) + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + X(J) = TEMP + 140 CONTINUE + ELSE + KX = KX + (N-1)*INCX + JX = KX + DO 160 J = N,1,-1 + TEMP = X(JX) + IX = KX + DO 150 I = N,J + 1,-1 + TEMP = TEMP - A(I,J)*X(IX) + IX = IX - INCX + 150 CONTINUE + IF (NOUNIT) TEMP = TEMP/A(J,J) + X(JX) = TEMP + JX = JX - INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of STRSV +* + END diff --git a/src/xerbla.c b/src/xerbla.c new file mode 100644 index 0000000..0d73705 --- /dev/null +++ b/src/xerbla.c @@ -0,0 +1,86 @@ +*> \brief \b XERBLA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE XERBLA( SRNAME, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER*(*) SRNAME +* INTEGER INFO +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> XERBLA is an error handler for the LAPACK routines. +*> It is called by an LAPACK routine if an input parameter has an +*> invalid value. A message is printed and execution stops. +*> +*> Installers may consider modifying the STOP statement in order to +*> call system-specific exception-handling facilities. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SRNAME +*> \verbatim +*> SRNAME is CHARACTER*(*) +*> The name of the routine which called XERBLA. +*> \endverbatim +*> +*> \param[in] INFO +*> \verbatim +*> INFO is INTEGER +*> The position of the invalid parameter in the parameter list +*> of the calling routine. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup aux_blas +* +* ===================================================================== + SUBROUTINE 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..-- +* +* .. Scalar Arguments .. + CHARACTER*(*) SRNAME + INTEGER INFO +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC LEN_TRIM +* .. +* .. Executable Statements .. +* + WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO +* + STOP +* + 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', + $ 'an illegal value' ) +* +* End of XERBLA +* + END diff --git a/src/xerbla_array.c b/src/xerbla_array.c new file mode 100644 index 0000000..1143094 --- /dev/null +++ b/src/xerbla_array.c @@ -0,0 +1,119 @@ +*> \brief \b XERBLA_ARRAY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE XERBLA_ARRAY(SRNAME_ARRAY, SRNAME_LEN, INFO) +* +* .. Scalar Arguments .. +* INTEGER SRNAME_LEN, INFO +* .. +* .. Array Arguments .. +* CHARACTER(1) SRNAME_ARRAY(SRNAME_LEN) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> XERBLA_ARRAY assists other languages in calling XERBLA, the LAPACK +*> and BLAS error handler. Rather than taking a Fortran string argument +*> as the function's name, XERBLA_ARRAY takes an array of single +*> characters along with the array's length. XERBLA_ARRAY then copies +*> up to 32 characters of that array into a Fortran string and passes +*> that to XERBLA. If called with a non-positive SRNAME_LEN, +*> XERBLA_ARRAY will call XERBLA with a string of all blank characters. +*> +*> Say some macro or other device makes XERBLA_ARRAY available to C99 +*> by a name lapack_xerbla and with a common Fortran calling convention. +*> Then a C99 program could invoke XERBLA via: +*> { +*> int flen = strlen(__func__); +*> lapack_xerbla(__func__, &flen, &info); +*> } +*> +*> Providing XERBLA_ARRAY is not necessary for intercepting LAPACK +*> errors. XERBLA_ARRAY calls XERBLA. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SRNAME_ARRAY +*> \verbatim +*> SRNAME_ARRAY is CHARACTER(1) array, dimension (SRNAME_LEN) +*> The name of the routine which called XERBLA_ARRAY. +*> \endverbatim +*> +*> \param[in] SRNAME_LEN +*> \verbatim +*> SRNAME_LEN is INTEGER +*> The length of the name in SRNAME_ARRAY. +*> \endverbatim +*> +*> \param[in] INFO +*> \verbatim +*> INFO is INTEGER +*> The position of the invalid parameter in the parameter list +*> of the calling routine. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \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 + + CALL XERBLA( SRNAME, INFO ) + + RETURN +* +* End of XERBLA_ARRAY +* + END diff --git a/src/zaxpy.c b/src/zaxpy.c new file mode 100644 index 0000000..35c0e4b --- /dev/null +++ b/src/zaxpy.c @@ -0,0 +1,139 @@ +*> \brief \b ZAXPY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZAXPY(N,ZA,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* COMPLEX*16 ZA +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZAXPY constant times a vector plus a vector. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZA +*> \verbatim +*> ZA is COMPLEX*16 +*> On entry, ZA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[in,out] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex16_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZAXPY(N,ZA,ZX,INCX,ZY,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..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ZA + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY +* .. +* .. External Functions .. + DOUBLE PRECISION DCABS1 + EXTERNAL DCABS1 +* .. + IF (N.LE.0) RETURN + IF (DCABS1(ZA).EQ.0.0d0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + ZY(I) = ZY(I) + ZA*ZX(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + ZY(IY) = ZY(IY) + ZA*ZX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF +* + RETURN +* +* End of ZAXPY +* + END diff --git a/src/zcopy.c b/src/zcopy.c new file mode 100644 index 0000000..1efcdb6 --- /dev/null +++ b/src/zcopy.c @@ -0,0 +1,125 @@ +*> \brief \b ZCOPY +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCOPY copies a vector, x, to a vector, y. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[out] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex16_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, linpack, 4/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZCOPY(N,ZX,INCX,ZY,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,IX,IY +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + ZY(I) = ZX(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + ZY(IY) = ZX(IX) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of ZCOPY +* + END diff --git a/src/zdotc.c b/src/zdotc.c new file mode 100644 index 0000000..bcc29e2 --- /dev/null +++ b/src/zdotc.c @@ -0,0 +1,134 @@ +*> \brief \b ZDOTC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* COMPLEX*16 FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDOTC forms the dot product of two complex vectors +*> ZDOTC = X^H * Y +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[in] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex16_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + COMPLEX*16 FUNCTION ZDOTC(N,ZX,INCX,ZY,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX*16 ZTEMP + INTEGER I,IX,IY +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. + ZTEMP = (0.0d0,0.0d0) + ZDOTC = (0.0d0,0.0d0) + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + ZTEMP = ZTEMP + DCONJG(ZX(I))*ZY(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + ZTEMP = ZTEMP + DCONJG(ZX(IX))*ZY(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + ZDOTC = ZTEMP + RETURN +* +* End of ZDOTC +* + END diff --git a/src/zdotu.c b/src/zdotu.c new file mode 100644 index 0000000..11c18da --- /dev/null +++ b/src/zdotu.c @@ -0,0 +1,131 @@ +*> \brief \b ZDOTU +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* COMPLEX*16 FUNCTION ZDOTU(N,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDOTU forms the dot product of two complex vectors +*> ZDOTU = X^T * Y +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[in] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex16_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + COMPLEX*16 FUNCTION ZDOTU(N,ZX,INCX,ZY,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX*16 ZTEMP + INTEGER I,IX,IY +* .. + ZTEMP = (0.0d0,0.0d0) + ZDOTU = (0.0d0,0.0d0) + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 +* + DO I = 1,N + ZTEMP = ZTEMP + ZX(I)*ZY(I) + END DO + ELSE +* +* code for unequal increments or equal increments +* not equal to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + ZTEMP = ZTEMP + ZX(IX)*ZY(IY) + IX = IX + INCX + IY = IY + INCY + END DO + END IF + ZDOTU = ZTEMP + RETURN +* +* End of ZDOTU +* + END diff --git a/src/zdrot.c b/src/zdrot.c new file mode 100644 index 0000000..3145561 --- /dev/null +++ b/src/zdrot.c @@ -0,0 +1,153 @@ +*> \brief \b ZDROT +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDROT( N, ZX, INCX, ZY, INCY, C, S ) +* +* .. Scalar Arguments .. +* INTEGER INCX, INCY, N +* DOUBLE PRECISION C, S +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX( * ), ZY( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Applies a plane rotation, where the cos and sin (c and s) are real +*> and the vectors cx and cy are complex. +*> jack dongarra, linpack, 3/11/78. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the order of the vectors cx and cy. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension at least +*> ( 1 + ( N - 1 )*abs( INCX ) ). +*> Before entry, the incremented array ZX must contain the n +*> element vector cx. On exit, ZX is overwritten by the updated +*> vector cx. +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> On entry, INCX specifies the increment for the elements of +*> ZX. INCX must not be zero. +*> \endverbatim +*> +*> \param[in,out] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension at least +*> ( 1 + ( N - 1 )*abs( INCY ) ). +*> Before entry, the incremented array ZY must contain the n +*> element vector cy. On exit, ZY is overwritten by the updated +*> vector cy. +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> On entry, INCY specifies the increment for the elements of +*> ZY. INCY must not be zero. +*> \endverbatim +*> +*> \param[in] C +*> \verbatim +*> C is DOUBLE PRECISION +*> On entry, C specifies the cosine, cos. +*> \endverbatim +*> +*> \param[in] S +*> \verbatim +*> S is DOUBLE PRECISION +*> On entry, S specifies the sine, sin. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex16_blas_level1 +* +* ===================================================================== + SUBROUTINE ZDROT( N, ZX, INCX, ZY, INCY, C, 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 .. + INTEGER INCX, INCY, N + DOUBLE PRECISION C, S +* .. +* .. Array Arguments .. + COMPLEX*16 ZX( * ), ZY( * ) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IX, IY + COMPLEX*16 CTEMP +* .. +* .. Executable Statements .. +* + IF( N.LE.0 ) + $ RETURN + IF( INCX.EQ.1 .AND. INCY.EQ.1 ) THEN +* +* code for both increments equal to 1 +* + DO I = 1, N + CTEMP = C*ZX( I ) + S*ZY( I ) + ZY( I ) = C*ZY( I ) - S*ZX( I ) + ZX( I ) = CTEMP + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF( INCX.LT.0 ) + $ IX = ( -N+1 )*INCX + 1 + IF( INCY.LT.0 ) + $ IY = ( -N+1 )*INCY + 1 + DO I = 1, N + CTEMP = C*ZX( IX ) + S*ZY( IY ) + ZY( IY ) = C*ZY( IY ) - S*ZX( IX ) + ZX( IX ) = CTEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of ZDROT +* + END diff --git a/src/zdscal.c b/src/zdscal.c new file mode 100644 index 0000000..5a16048 --- /dev/null +++ b/src/zdscal.c @@ -0,0 +1,123 @@ +*> \brief \b ZDSCAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDSCAL(N,DA,ZX,INCX) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION DA +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDSCAL scales a vector by a constant. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] DA +*> \verbatim +*> DA is DOUBLE PRECISION +*> On entry, DA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex16_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZDSCAL(N,DA,ZX,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..-- +* +* .. Scalar Arguments .. + DOUBLE PRECISION DA + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,NINCX +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER (ONE=1.0D+0) +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, DIMAG +* .. + IF (N.LE.0 .OR. INCX.LE.0 .OR. DA.EQ.ONE) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DO I = 1,N + ZX(I) = DCMPLX(DA*DBLE(ZX(I)),DA*DIMAG(ZX(I))) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + ZX(I) = DCMPLX(DA*DBLE(ZX(I)),DA*DIMAG(ZX(I))) + END DO + END IF + RETURN +* +* End of ZDSCAL +* + END diff --git a/src/zgbmv.c b/src/zgbmv.c new file mode 100644 index 0000000..0bca54e --- /dev/null +++ b/src/zgbmv.c @@ -0,0 +1,387 @@ +*> \brief \b ZGBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER INCX,INCY,KL,KU,LDA,M,N +* CHARACTER TRANS +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGBMV 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*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 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*16 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*16 +*> 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*16 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 complex16_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 ZGBMV(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*16 ALPHA,BETA + INTEGER INCX,INCY,KL,KU,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 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 DCONJG,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('ZGBMV ',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 + DCONJG(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 + DCONJG(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 ZGBMV +* + END diff --git a/src/zgemm.c b/src/zgemm.c new file mode 100644 index 0000000..0b712f1 --- /dev/null +++ b/src/zgemm.c @@ -0,0 +1,477 @@ +*> \brief \b ZGEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,M,N +* CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEMM performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T or op( X ) = X**H, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \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] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**H. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix +*> op( A ) and of the matrix C. 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 +*> op( B ) and the number of columns of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is m otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading m by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \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 TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX*16 array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \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 TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \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, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex16_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 ZGEMM(TRANSA,TRANSB,M,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*16 ALPHA,BETA + INTEGER K,LDA,LDB,LDC,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,L,NROWA,NROWB + LOGICAL CONJA,CONJB,NOTA,NOTB +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* +* 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 and NROWB as the number of rows of A and B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + CONJA = LSAME(TRANSA,'C') + CONJB = LSAME(TRANSB,'C') + IF (NOTA) THEN + NROWA = M + ELSE + NROWA = K + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.NOTA) .AND. (.NOT.CONJA) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZGEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (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 (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 (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 50 I = 1,M + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = 1,M + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE IF (CONJA) THEN +* +* Form C := alpha*A**H*B + beta*C. +* + DO 120 J = 1,N + DO 110 I = 1,M + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 150 J = 1,N + DO 140 I = 1,M + TEMP = ZERO + DO 130 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 130 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 140 CONTINUE + 150 CONTINUE + END IF + ELSE IF (NOTA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A*B**H + beta*C. +* + DO 200 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 160 I = 1,M + C(I,J) = ZERO + 160 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 170 I = 1,M + C(I,J) = BETA*C(I,J) + 170 CONTINUE + END IF + DO 190 L = 1,K + TEMP = ALPHA*DCONJG(B(J,L)) + DO 180 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + ELSE +* +* Form C := alpha*A*B**T + beta*C +* + DO 250 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 210 I = 1,M + C(I,J) = ZERO + 210 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 220 I = 1,M + C(I,J) = BETA*C(I,J) + 220 CONTINUE + END IF + DO 240 L = 1,K + TEMP = ALPHA*B(J,L) + DO 230 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + END IF + ELSE IF (CONJA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A**H*B**H + beta*C. +* + DO 280 J = 1,N + DO 270 I = 1,M + TEMP = ZERO + DO 260 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*DCONJG(B(J,L)) + 260 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 270 CONTINUE + 280 CONTINUE + ELSE +* +* Form C := alpha*A**H*B**T + beta*C +* + DO 310 J = 1,N + DO 300 I = 1,M + TEMP = ZERO + DO 290 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*B(J,L) + 290 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 300 CONTINUE + 310 CONTINUE + END IF + ELSE + IF (CONJB) THEN +* +* Form C := alpha*A**T*B**H + beta*C +* + DO 340 J = 1,N + DO 330 I = 1,M + TEMP = ZERO + DO 320 L = 1,K + TEMP = TEMP + A(L,I)*DCONJG(B(J,L)) + 320 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 330 CONTINUE + 340 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 370 J = 1,N + DO 360 I = 1,M + TEMP = ZERO + DO 350 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 350 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 360 CONTINUE + 370 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGEMM +* + END diff --git a/src/zgemv.c b/src/zgemv.c new file mode 100644 index 0000000..2664454 --- /dev/null +++ b/src/zgemv.c @@ -0,0 +1,347 @@ +*> \brief \b ZGEMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER INCX,INCY,LDA,M,N +* CHARACTER TRANS +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEMV 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 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**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] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 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 COMPLEX*16 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*16 +*> 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*16 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 complex16_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 ZGEMV(TRANS,M,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*16 ALPHA,BETA + INTEGER INCX,INCY,LDA,M,N + CHARACTER TRANS +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY + LOGICAL NOCONJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* +* 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 (LDA.LT.MAX(1,M)) 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('ZGEMV ',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 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 + 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) + DO 50 I = 1,M + Y(I) = Y(I) + TEMP*A(I,J) + 50 CONTINUE + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80 J = 1,N + TEMP = ALPHA*X(JX) + IY = KY + DO 70 I = 1,M + Y(IY) = Y(IY) + TEMP*A(I,J) + IY = IY + INCY + 70 CONTINUE + JX = JX + INCX + 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 + IF (NOCONJ) THEN + DO 90 I = 1,M + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + ELSE + DO 100 I = 1,M + TEMP = TEMP + DCONJG(A(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 + IF (NOCONJ) THEN + DO 120 I = 1,M + TEMP = TEMP + A(I,J)*X(IX) + IX = IX + INCX + 120 CONTINUE + ELSE + DO 130 I = 1,M + TEMP = TEMP + DCONJG(A(I,J))*X(IX) + IX = IX + INCX + 130 CONTINUE + END IF + Y(JY) = Y(JY) + ALPHA*TEMP + JY = JY + INCY + 140 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGEMV +* + END diff --git a/src/zgerc.c b/src/zgerc.c new file mode 100644 index 0000000..2eb4349 --- /dev/null +++ b/src/zgerc.c @@ -0,0 +1,224 @@ +*> \brief \b ZGERC +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGERC(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGERC performs the rank 1 operation +*> +*> A := alpha*x*y**H + 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 COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 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 COMPLEX*16 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*16 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 complex16_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 ZGERC(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*16 ALPHA + INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JY,KX +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,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('ZGERC ',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*DCONJG(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*DCONJG(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 ZGERC +* + END diff --git a/src/zgeru.c b/src/zgeru.c new file mode 100644 index 0000000..e1cd2dc --- /dev/null +++ b/src/zgeru.c @@ -0,0 +1,224 @@ +*> \brief \b ZGERU +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGERU(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGERU 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 COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 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 COMPLEX*16 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*16 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 complex16_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 ZGERU(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*16 ALPHA + INTEGER INCX,INCY,LDA,M,N +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 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('ZGERU ',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 ZGERU +* + END diff --git a/src/zhbmv.c b/src/zhbmv.c new file mode 100644 index 0000000..6f8026c --- /dev/null +++ b/src/zhbmv.c @@ -0,0 +1,377 @@ +*> \brief \b ZHBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER INCX,INCY,K,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHBMV 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 band matrix, with k super-diagonals. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the band matrix A is being supplied as +*> follows: +*> +*> UPLO = 'U' or 'u' The upper triangular part of A is +*> being supplied. +*> +*> UPLO = 'L' or 'l' The lower triangular part of A is +*> being supplied. +*> \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, K specifies the number of super-diagonals of the +*> matrix A. K must satisfy 0 .le. K. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 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 hermitian matrix, 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 the upper +*> triangular part of a hermitian 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 hermitian matrix, 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 the lower +*> triangular part of a hermitian 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 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 +*> ( k + 1 ). +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCX ) ). +*> 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*16 +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] Y +*> \verbatim +*> Y is COMPLEX*16 array, dimension at least +*> ( 1 + ( n - 1 )*abs( INCY ) ). +*> 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 complex16_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 ZHBMV(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*16 ALPHA,BETA + INTEGER INCX,INCY,K,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 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 DBLE,DCONJG,MAX,MIN +* .. +* +* 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('ZHBMV ',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 + DCONJG(A(L+I,J))*X(I) + 50 CONTINUE + Y(J) = Y(J) + TEMP1*DBLE(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 + DCONJG(A(L+I,J))*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*DBLE(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*DBLE(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 + DCONJG(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*DBLE(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 + DCONJG(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 ZHBMV +* + END diff --git a/src/zhemm.c b/src/zhemm.c new file mode 100644 index 0000000..9ebbab2 --- /dev/null +++ b/src/zhemm.c @@ -0,0 +1,368 @@ +*> \brief \b ZHEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER LDA,LDB,LDC,M,N +* CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHEMM performs one of the matrix-matrix operations +*> +*> C := alpha*A*B + beta*C, +*> +*> or +*> +*> C := alpha*B*A + beta*C, +*> +*> where alpha and beta are scalars, A is an hermitian matrix and B and +*> C are m by n matrices. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether the hermitian matrix A +*> appears on the left or right in the operation as follows: +*> +*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C, +*> +*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C, +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the hermitian matrix A is to be +*> referenced as follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of the +*> hermitian matrix is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of the +*> hermitian matrix is to be referenced. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix C. +*> 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 C. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is +*> m when SIDE = 'L' or 'l' and is n otherwise. +*> Before entry with SIDE = 'L' or 'l', the m by m part of +*> the array A must contain the hermitian matrix, such that +*> when UPLO = 'U' or 'u', the leading m by m upper triangular +*> part of the array A must contain the upper triangular part +*> of the hermitian matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading m by m lower triangular part of the array A +*> must contain the lower triangular part of the hermitian +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> Before entry with SIDE = 'R' or 'r', the n by n part of +*> the array A must contain the hermitian matrix, such that +*> when UPLO = 'U' or 'u', the leading n by n upper triangular +*> part of the array A must contain the upper triangular part +*> of the hermitian matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading n by n lower triangular part of the array A +*> must contain the lower triangular part of the 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, they 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. When SIDE = 'L' or 'l' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX*16 array, dimension ( LDB, N ) +*> Before entry, the leading m 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. LDB must be at least +*> max( 1, m ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n updated +*> matrix. +*> \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, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex16_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 ZHEMM(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*16 ALPHA,BETA + INTEGER LDA,LDB,LDC,M,N + CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE,DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP1,TEMP2 + INTEGER I,INFO,J,K,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+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('ZHEMM ',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)*DCONJG(A(K,I)) + 50 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = TEMP1*DBLE(A(I,I)) + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + TEMP1*DBLE(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)*DCONJG(A(K,I)) + 80 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = TEMP1*DBLE(A(I,I)) + ALPHA*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + TEMP1*DBLE(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*DBLE(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*DCONJG(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*DCONJG(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 ZHEMM +* + END diff --git a/src/zhemv.c b/src/zhemv.c new file mode 100644 index 0000000..dad68bf --- /dev/null +++ b/src/zhemv.c @@ -0,0 +1,334 @@ +*> \brief \b ZHEMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHEMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER INCX,INCY,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHEMV 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*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 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*16 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*16 +*> 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*16 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 complex16_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 ZHEMV(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*16 ALPHA,BETA + INTEGER INCX,INCY,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 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 DBLE,DCONJG,MAX +* .. +* +* 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('ZHEMV ',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 + DCONJG(A(I,J))*X(I) + 50 CONTINUE + Y(J) = Y(J) + TEMP1*DBLE(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 + DCONJG(A(I,J))*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*DBLE(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*DBLE(A(J,J)) + DO 90 I = J + 1,N + Y(I) = Y(I) + TEMP1*A(I,J) + TEMP2 = TEMP2 + DCONJG(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*DBLE(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 + DCONJG(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 ZHEMV +* + END diff --git a/src/zher.c b/src/zher.c new file mode 100644 index 0000000..5922730 --- /dev/null +++ b/src/zher.c @@ -0,0 +1,275 @@ +*> \brief \b ZHER +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHER(UPLO,N,ALPHA,X,INCX,A,LDA) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA +* INTEGER INCX,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHER 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 DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 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*16 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 complex16_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 ZHER(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 .. + DOUBLE PRECISION ALPHA + INTEGER INCX,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JX,KX +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE,DCONJG,MAX +* .. +* +* 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('ZHER ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.DBLE(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*DCONJG(X(J)) + DO 10 I = 1,J - 1 + A(I,J) = A(I,J) + X(I)*TEMP + 10 CONTINUE + A(J,J) = DBLE(A(J,J)) + DBLE(X(J)*TEMP) + ELSE + A(J,J) = DBLE(A(J,J)) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*DCONJG(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) = DBLE(A(J,J)) + DBLE(X(JX)*TEMP) + ELSE + A(J,J) = DBLE(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*DCONJG(X(J)) + A(J,J) = DBLE(A(J,J)) + DBLE(TEMP*X(J)) + DO 50 I = J + 1,N + A(I,J) = A(I,J) + X(I)*TEMP + 50 CONTINUE + ELSE + A(J,J) = DBLE(A(J,J)) + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = ALPHA*DCONJG(X(JX)) + A(J,J) = DBLE(A(J,J)) + DBLE(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) = DBLE(A(J,J)) + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHER +* + END diff --git a/src/zher2.c b/src/zher2.c new file mode 100644 index 0000000..d1f2b57 --- /dev/null +++ b/src/zher2.c @@ -0,0 +1,314 @@ +*> \brief \b ZHER2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHER2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER INCX,INCY,LDA,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHER2 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*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 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*16 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*16 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 complex16_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 ZHER2(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*16 ALPHA + INTEGER INCX,INCY,LDA,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 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 DBLE,DCONJG,MAX +* .. +* +* 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('ZHER2 ',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*DCONJG(Y(J)) + TEMP2 = DCONJG(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) = DBLE(A(J,J)) + + + DBLE(X(J)*TEMP1+Y(J)*TEMP2) + ELSE + A(J,J) = DBLE(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*DCONJG(Y(JY)) + TEMP2 = DCONJG(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) = DBLE(A(J,J)) + + + DBLE(X(JX)*TEMP1+Y(JY)*TEMP2) + ELSE + A(J,J) = DBLE(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*DCONJG(Y(J)) + TEMP2 = DCONJG(ALPHA*X(J)) + A(J,J) = DBLE(A(J,J)) + + + DBLE(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) = DBLE(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*DCONJG(Y(JY)) + TEMP2 = DCONJG(ALPHA*X(JX)) + A(J,J) = DBLE(A(J,J)) + + + DBLE(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) = DBLE(A(J,J)) + END IF + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHER2 +* + END diff --git a/src/zher2k.c b/src/zher2k.c new file mode 100644 index 0000000..5c75083 --- /dev/null +++ b/src/zher2k.c @@ -0,0 +1,440 @@ +*> \brief \b ZHER2K +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHER2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* DOUBLE PRECISION BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHER2K 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*16 . +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 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*16 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 ). +*> Unchanged on exit. +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION . +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 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 complex16_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 DBLE( C(J,J) ) when BETA = 1. +*> Ed Anderson, Cray Research Inc. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZHER2K(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*16 ALPHA + DOUBLE PRECISION BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE,DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP1,TEMP2 + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER (ONE=1.0D+0) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+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('ZHER2K',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.DBLE(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*DBLE(C(J,J)) + 40 CONTINUE + END IF + ELSE + IF (BETA.EQ.DBLE(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*DBLE(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.DBLE(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*DBLE(C(J,J)) + ELSE + C(J,J) = DBLE(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*DCONJG(B(J,L)) + TEMP2 = DCONJG(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) = DBLE(C(J,J)) + + + DBLE(A(J,L)*TEMP1+B(J,L)*TEMP2) + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180 J = 1,N + IF (BETA.EQ.DBLE(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*DBLE(C(J,J)) + ELSE + C(J,J) = DBLE(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*DCONJG(B(J,L)) + TEMP2 = DCONJG(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) = DBLE(C(J,J)) + + + DBLE(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 + DCONJG(A(L,I))*B(L,J) + TEMP2 = TEMP2 + DCONJG(B(L,I))*A(L,J) + 190 CONTINUE + IF (I.EQ.J) THEN + IF (BETA.EQ.DBLE(ZERO)) THEN + C(J,J) = DBLE(ALPHA*TEMP1+ + + DCONJG(ALPHA)*TEMP2) + ELSE + C(J,J) = BETA*DBLE(C(J,J)) + + + DBLE(ALPHA*TEMP1+ + + DCONJG(ALPHA)*TEMP2) + END IF + ELSE + IF (BETA.EQ.DBLE(ZERO)) THEN + C(I,J) = ALPHA*TEMP1 + DCONJG(ALPHA)*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + + + DCONJG(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 + DCONJG(A(L,I))*B(L,J) + TEMP2 = TEMP2 + DCONJG(B(L,I))*A(L,J) + 220 CONTINUE + IF (I.EQ.J) THEN + IF (BETA.EQ.DBLE(ZERO)) THEN + C(J,J) = DBLE(ALPHA*TEMP1+ + + DCONJG(ALPHA)*TEMP2) + ELSE + C(J,J) = BETA*DBLE(C(J,J)) + + + DBLE(ALPHA*TEMP1+ + + DCONJG(ALPHA)*TEMP2) + END IF + ELSE + IF (BETA.EQ.DBLE(ZERO)) THEN + C(I,J) = ALPHA*TEMP1 + DCONJG(ALPHA)*TEMP2 + ELSE + C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + + + DCONJG(ALPHA)*TEMP2 + END IF + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHER2K +* + END diff --git a/src/zherk.c b/src/zherk.c new file mode 100644 index 0000000..f2665e6 --- /dev/null +++ b/src/zherk.c @@ -0,0 +1,393 @@ +*> \brief \b ZHERK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER K,LDA,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHERK 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 DOUBLE PRECISION . +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 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 DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 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 complex16_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 DBLE( C(J,J) ) when BETA = 1. +*> Ed Anderson, Cray Research Inc. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZHERK(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 .. + DOUBLE PRECISION ALPHA,BETA + INTEGER K,LDA,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE,DCMPLX,DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + DOUBLE PRECISION RTEMP + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+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('ZHERK ',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*DBLE(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*DBLE(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*DBLE(C(J,J)) + ELSE + C(J,J) = DBLE(C(J,J)) + END IF + DO 120 L = 1,K + IF (A(J,L).NE.DCMPLX(ZERO)) THEN + TEMP = ALPHA*DCONJG(A(J,L)) + DO 110 I = 1,J - 1 + C(I,J) = C(I,J) + TEMP*A(I,L) + 110 CONTINUE + C(J,J) = DBLE(C(J,J)) + DBLE(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*DBLE(C(J,J)) + DO 150 I = J + 1,N + C(I,J) = BETA*C(I,J) + 150 CONTINUE + ELSE + C(J,J) = DBLE(C(J,J)) + END IF + DO 170 L = 1,K + IF (A(J,L).NE.DCMPLX(ZERO)) THEN + TEMP = ALPHA*DCONJG(A(J,L)) + C(J,J) = DBLE(C(J,J)) + DBLE(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 + DCONJG(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 + DBLE(DCONJG(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*DBLE(C(J,J)) + END IF + 220 CONTINUE + ELSE + DO 260 J = 1,N + RTEMP = ZERO + DO 230 L = 1,K + RTEMP = RTEMP + DBLE(DCONJG(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*DBLE(C(J,J)) + END IF + DO 250 I = J + 1,N + TEMP = ZERO + DO 240 L = 1,K + TEMP = TEMP + DCONJG(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 ZHERK +* + END diff --git a/src/zhpmv.c b/src/zhpmv.c new file mode 100644 index 0000000..c1a2fa0 --- /dev/null +++ b/src/zhpmv.c @@ -0,0 +1,335 @@ +*> \brief \b ZHPMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER INCX,INCY,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 AP(*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHPMV 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*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is COMPLEX*16 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*16 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*16 +*> 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*16 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 complex16_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 ZHPMV(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*16 ALPHA,BETA + INTEGER INCX,INCY,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 AP(*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 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 DBLE,DCONJG +* .. +* +* 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('ZHPMV ',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 + DCONJG(AP(K))*X(I) + K = K + 1 + 50 CONTINUE + Y(J) = Y(J) + TEMP1*DBLE(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 + DCONJG(AP(K))*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) + TEMP1*DBLE(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*DBLE(AP(KK)) + K = KK + 1 + DO 90 I = J + 1,N + Y(I) = Y(I) + TEMP1*AP(K) + TEMP2 = TEMP2 + DCONJG(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*DBLE(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 + DCONJG(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 ZHPMV +* + END diff --git a/src/zhpr.c b/src/zhpr.c new file mode 100644 index 0000000..2ba5774 --- /dev/null +++ b/src/zhpr.c @@ -0,0 +1,276 @@ +*> \brief \b ZHPR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHPR(UPLO,N,ALPHA,X,INCX,AP) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA +* INTEGER INCX,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHPR 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 DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 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*16 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 complex16_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 ZHPR(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 .. + DOUBLE PRECISION ALPHA + INTEGER INCX,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JX,K,KK,KX +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE,DCONJG +* .. +* +* 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('ZHPR ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((N.EQ.0) .OR. (ALPHA.EQ.DBLE(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*DCONJG(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) = DBLE(AP(KK+J-1)) + DBLE(X(J)*TEMP) + ELSE + AP(KK+J-1) = DBLE(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*DCONJG(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) = DBLE(AP(KK+J-1)) + DBLE(X(JX)*TEMP) + ELSE + AP(KK+J-1) = DBLE(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*DCONJG(X(J)) + AP(KK) = DBLE(AP(KK)) + DBLE(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) = DBLE(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*DCONJG(X(JX)) + AP(KK) = DBLE(AP(KK)) + DBLE(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) = DBLE(AP(KK)) + END IF + JX = JX + INCX + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHPR +* + END diff --git a/src/zhpr2.c b/src/zhpr2.c new file mode 100644 index 0000000..55cfe77 --- /dev/null +++ b/src/zhpr2.c @@ -0,0 +1,315 @@ +*> \brief \b ZHPR2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER INCX,INCY,N +* CHARACTER UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 AP(*),X(*),Y(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHPR2 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*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] X +*> \verbatim +*> X is COMPLEX*16 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*16 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*16 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 complex16_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 ZHPR2(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*16 ALPHA + INTEGER INCX,INCY,N + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 AP(*),X(*),Y(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 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 DBLE,DCONJG +* .. +* +* 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('ZHPR2 ',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*DCONJG(Y(J)) + TEMP2 = DCONJG(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) = DBLE(AP(KK+J-1)) + + + DBLE(X(J)*TEMP1+Y(J)*TEMP2) + ELSE + AP(KK+J-1) = DBLE(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*DCONJG(Y(JY)) + TEMP2 = DCONJG(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) = DBLE(AP(KK+J-1)) + + + DBLE(X(JX)*TEMP1+Y(JY)*TEMP2) + ELSE + AP(KK+J-1) = DBLE(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*DCONJG(Y(J)) + TEMP2 = DCONJG(ALPHA*X(J)) + AP(KK) = DBLE(AP(KK)) + + + DBLE(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) = DBLE(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*DCONJG(Y(JY)) + TEMP2 = DCONJG(ALPHA*X(JX)) + AP(KK) = DBLE(AP(KK)) + + + DBLE(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) = DBLE(AP(KK)) + END IF + JX = JX + INCX + JY = JY + INCY + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZHPR2 +* + END diff --git a/src/zrotg.c b/src/zrotg.c new file mode 100644 index 0000000..b3c23be --- /dev/null +++ b/src/zrotg.c @@ -0,0 +1,277 @@ +!> \brief \b ZROTG generates a Givens rotation with real cosine and complex sine. +! +! =========== DOCUMENTATION =========== +! +! Online html documentation available at +! http://www.netlib.org/lapack/explore-html/ +! +! Definition: +! =========== +! +! ZROTG 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 DROTG when |a| > |b|. When |b| >= |a|, the +!> sign of c and s will be different from those computed by DROTG +!> if the signs of a and b are not the same. +!> +!> \endverbatim +! +! Arguments: +! ========== +! +!> \param[in,out] A +!> \verbatim +!> A is DOUBLE COMPLEX +!> On entry, the scalar a. +!> On exit, the scalar r. +!> \endverbatim +!> +!> \param[in] B +!> \verbatim +!> B is DOUBLE COMPLEX +!> The scalar b. +!> \endverbatim +!> +!> \param[out] C +!> \verbatim +!> C is DOUBLE PRECISION +!> The scalar c. +!> \endverbatim +!> +!> \param[out] S +!> \verbatim +!> S is DOUBLE 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 ZROTG( a, b, c, s ) + integer, parameter :: wp = kind(1.d0) +! +! -- 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/zscal.c b/src/zscal.c new file mode 100644 index 0000000..8b8c2c8 --- /dev/null +++ b/src/zscal.c @@ -0,0 +1,121 @@ +*> \brief \b ZSCAL +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSCAL(N,ZA,ZX,INCX) +* +* .. Scalar Arguments .. +* COMPLEX*16 ZA +* INTEGER INCX,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSCAL scales a vector by a constant. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in] ZA +*> \verbatim +*> ZA is COMPLEX*16 +*> On entry, ZA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex16_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 3/93 to return if incx .le. 0. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZSCAL(N,ZA,ZX,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..-- +* +* .. Scalar Arguments .. + COMPLEX*16 ZA + INTEGER INCX,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I,NINCX +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) +* .. + IF (N.LE.0 .OR. INCX.LE.0 .OR. ZA.EQ.ONE) RETURN + IF (INCX.EQ.1) THEN +* +* code for increment equal to 1 +* + DO I = 1,N + ZX(I) = ZA*ZX(I) + END DO + ELSE +* +* code for increment not equal to 1 +* + NINCX = N*INCX + DO I = 1,NINCX,INCX + ZX(I) = ZA*ZX(I) + END DO + END IF + RETURN +* +* End of ZSCAL +* + END diff --git a/src/zswap.c b/src/zswap.c new file mode 100644 index 0000000..93f8fc5 --- /dev/null +++ b/src/zswap.c @@ -0,0 +1,129 @@ +*> \brief \b ZSWAP +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSWAP(N,ZX,INCX,ZY,INCY) +* +* .. Scalar Arguments .. +* INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. +* COMPLEX*16 ZX(*),ZY(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSWAP interchanges two vectors. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> number of elements in input vector(s) +*> \endverbatim +*> +*> \param[in,out] ZX +*> \verbatim +*> ZX is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCX ) ) +*> \endverbatim +*> +*> \param[in] INCX +*> \verbatim +*> INCX is INTEGER +*> storage spacing between elements of ZX +*> \endverbatim +*> +*> \param[in,out] ZY +*> \verbatim +*> ZY is COMPLEX*16 array, dimension ( 1 + ( N - 1 )*abs( INCY ) ) +*> \endverbatim +*> +*> \param[in] INCY +*> \verbatim +*> INCY is INTEGER +*> storage spacing between elements of ZY +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex16_blas_level1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> jack dongarra, 3/11/78. +*> modified 12/3/93, array(1) declarations changed to array(*) +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZSWAP(N,ZX,INCX,ZY,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..-- +* +* .. Scalar Arguments .. + INTEGER INCX,INCY,N +* .. +* .. Array Arguments .. + COMPLEX*16 ZX(*),ZY(*) +* .. +* +* ===================================================================== +* +* .. Local Scalars .. + COMPLEX*16 ZTEMP + INTEGER I,IX,IY +* .. + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN +* +* code for both increments equal to 1 + DO I = 1,N + ZTEMP = ZX(I) + ZX(I) = ZY(I) + ZY(I) = ZTEMP + END DO + ELSE +* +* code for unequal increments or equal increments not equal +* to 1 +* + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO I = 1,N + ZTEMP = ZX(IX) + ZX(IX) = ZY(IY) + ZY(IY) = ZTEMP + IX = IX + INCX + IY = IY + INCY + END DO + END IF + RETURN +* +* End of ZSWAP +* + END diff --git a/src/zsymm.c b/src/zsymm.c new file mode 100644 index 0000000..3ec8a8d --- /dev/null +++ b/src/zsymm.c @@ -0,0 +1,366 @@ +*> \brief \b ZSYMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER LDA,LDB,LDC,M,N +* CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSYMM performs one of the matrix-matrix operations +*> +*> C := alpha*A*B + beta*C, +*> +*> or +*> +*> C := alpha*B*A + beta*C, +*> +*> where alpha and beta are scalars, A is a symmetric matrix and B and +*> C are m by n matrices. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> On entry, SIDE specifies whether the symmetric matrix A +*> appears on the left or right in the operation as follows: +*> +*> SIDE = 'L' or 'l' C := alpha*A*B + beta*C, +*> +*> SIDE = 'R' or 'r' C := alpha*B*A + beta*C, +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> On entry, UPLO specifies whether the upper or lower +*> triangular part of the symmetric matrix A is to be +*> referenced as follows: +*> +*> UPLO = 'U' or 'u' Only the upper triangular part of the +*> symmetric matrix is to be referenced. +*> +*> UPLO = 'L' or 'l' Only the lower triangular part of the +*> symmetric matrix is to be referenced. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix C. +*> 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 C. +*> N must be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is +*> m when SIDE = 'L' or 'l' and is n otherwise. +*> Before entry with SIDE = 'L' or 'l', the m by m part of +*> the array A must contain the symmetric matrix, such that +*> when UPLO = 'U' or 'u', the leading m by m upper triangular +*> part of the array A must contain the upper triangular part +*> of the symmetric matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading m by m lower triangular part of the array A +*> must contain the lower triangular part of the symmetric +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> Before entry with SIDE = 'R' or 'r', the n by n part of +*> the array A must contain the symmetric matrix, such that +*> when UPLO = 'U' or 'u', the leading n by n upper triangular +*> part of the array A must contain the upper triangular part +*> of the symmetric matrix and the strictly lower triangular +*> part of A is not referenced, and when UPLO = 'L' or 'l', +*> the leading n by n lower triangular part of the array A +*> must contain the lower triangular part of the symmetric +*> matrix and the strictly upper triangular part of A is not +*> referenced. +*> \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 ), otherwise LDA must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX*16 array, dimension ( LDB, N ) +*> Before entry, the leading m 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. LDB must be at least +*> max( 1, m ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n updated +*> matrix. +*> \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, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex16_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 ZSYMM(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*16 ALPHA,BETA + INTEGER LDA,LDB,LDC,M,N + CHARACTER SIDE,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP1,TEMP2 + INTEGER I,INFO,J,K,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+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('ZSYMM ',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 ZSYMM +* + END diff --git a/src/zsyr2k.c b/src/zsyr2k.c new file mode 100644 index 0000000..e0f89bb --- /dev/null +++ b/src/zsyr2k.c @@ -0,0 +1,393 @@ +*> \brief \b ZSYR2K +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSYR2K 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*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 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*16 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*16 +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 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 complex16_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 ZSYR2K(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*16 ALPHA,BETA + INTEGER K,LDA,LDB,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP1,TEMP2 + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+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('ZSYR2K',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 ZSYR2K +* + END diff --git a/src/zsyrk.c b/src/zsyrk.c new file mode 100644 index 0000000..143a5e2 --- /dev/null +++ b/src/zsyrk.c @@ -0,0 +1,360 @@ +*> \brief \b ZSYRK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER K,LDA,LDC,N +* CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSYRK 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*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 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*16 +*> On entry, BETA specifies the scalar beta. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 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 complex16_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 ZSYRK(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*16 ALPHA,BETA + INTEGER K,LDA,LDC,N + CHARACTER TRANS,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,L,NROWA + LOGICAL UPPER +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+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('ZSYRK ',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 ZSYRK +* + END diff --git a/src/ztbmv.c b/src/ztbmv.c new file mode 100644 index 0000000..6be39d0 --- /dev/null +++ b/src/ztbmv.c @@ -0,0 +1,426 @@ +*> \brief \b ZTBMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,K,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTBMV 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*16 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*16 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 complex16_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 ZTBMV(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*16 A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 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 DCONJG,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('ZTBMV ',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*DCONJG(A(KPLUS1,J)) + DO 100 I = J - 1,MAX(1,J-K),-1 + TEMP = TEMP + DCONJG(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*DCONJG(A(KPLUS1,J)) + DO 130 I = J - 1,MAX(1,J-K),-1 + TEMP = TEMP + DCONJG(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*DCONJG(A(1,J)) + DO 160 I = J + 1,MIN(N,J+K) + TEMP = TEMP + DCONJG(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*DCONJG(A(1,J)) + DO 190 I = J + 1,MIN(N,J+K) + TEMP = TEMP + DCONJG(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 ZTBMV +* + END diff --git a/src/ztbsv.c b/src/ztbsv.c new file mode 100644 index 0000000..41b5407 --- /dev/null +++ b/src/ztbsv.c @@ -0,0 +1,429 @@ +*> \brief \b ZTBSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,K,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTBSV 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*16 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*16 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 complex16_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 ZTBSV(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*16 A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 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 DCONJG,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('ZTBSV ',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 - DCONJG(A(L+I,J))*X(I) + 100 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(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 - DCONJG(A(L+I,J))*X(IX) + IX = IX + INCX + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(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 - DCONJG(A(L+I,J))*X(I) + 160 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(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 - DCONJG(A(L+I,J))*X(IX) + IX = IX - INCX + 190 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(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 ZTBSV +* + END diff --git a/src/ztpmv.c b/src/ztpmv.c new file mode 100644 index 0000000..363fd5a --- /dev/null +++ b/src/ztpmv.c @@ -0,0 +1,385 @@ +*> \brief \b ZTPMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTPMV 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*16 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*16 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 complex16_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 ZTPMV(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*16 AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 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 DCONJG +* .. +* +* 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('ZTPMV ',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*DCONJG(AP(KK)) + DO 100 I = J - 1,1,-1 + TEMP = TEMP + DCONJG(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*DCONJG(AP(KK)) + DO 130 K = KK - 1,KK - J + 1,-1 + IX = IX - INCX + TEMP = TEMP + DCONJG(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*DCONJG(AP(KK)) + DO 160 I = J + 1,N + TEMP = TEMP + DCONJG(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*DCONJG(AP(KK)) + DO 190 K = KK + 1,KK + N - J + IX = IX + INCX + TEMP = TEMP + DCONJG(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 ZTPMV +* + END diff --git a/src/ztpsv.c b/src/ztpsv.c new file mode 100644 index 0000000..c6f24d0 --- /dev/null +++ b/src/ztpsv.c @@ -0,0 +1,387 @@ +*> \brief \b ZTPSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 AP(*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTPSV 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*16 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*16 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 complex16_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 ZTPSV(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*16 AP(*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 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 DCONJG +* .. +* +* 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('ZTPSV ',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 - DCONJG(AP(K))*X(I) + K = K + 1 + 100 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(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 - DCONJG(AP(K))*X(IX) + IX = IX + INCX + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(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 - DCONJG(AP(K))*X(I) + K = K - 1 + 160 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(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 - DCONJG(AP(K))*X(IX) + IX = IX - INCX + 190 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(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 ZTPSV +* + END diff --git a/src/ztrmm.c b/src/ztrmm.c new file mode 100644 index 0000000..c59c367 --- /dev/null +++ b/src/ztrmm.c @@ -0,0 +1,449 @@ +*> \brief \b ZTRMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER LDA,LDB,M,N +* CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRMM 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*16 +*> 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*16 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*16 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 complex16_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 ZTRMM(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*16 ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+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('ZTRMM ',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*DCONJG(A(I,I)) + DO 100 K = 1,I - 1 + TEMP = TEMP + DCONJG(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*DCONJG(A(I,I)) + DO 140 K = I + 1,M + TEMP = TEMP + DCONJG(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*DCONJG(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*DCONJG(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*DCONJG(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*DCONJG(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 ZTRMM +* + END diff --git a/src/ztrmv.c b/src/ztrmv.c new file mode 100644 index 0000000..e8314fa --- /dev/null +++ b/src/ztrmv.c @@ -0,0 +1,370 @@ +*> \brief \b ZTRMV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRMV 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*16 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*16 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 complex16_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 ZTRMV(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*16 A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOCONJ,NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,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('ZTRMV ',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 + IF (INCX.EQ.1) THEN + DO 20 J = 1,N + IF (X(J).NE.ZERO) THEN + TEMP = X(J) + DO 10 I = 1,J - 1 + X(I) = X(I) + TEMP*A(I,J) + 10 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,J) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40 J = 1,N + IF (X(JX).NE.ZERO) THEN + TEMP = X(JX) + IX = KX + DO 30 I = 1,J - 1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX + INCX + 30 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX + 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) + DO 50 I = N,J + 1,-1 + X(I) = X(I) + TEMP*A(I,J) + 50 CONTINUE + IF (NOUNIT) X(J) = X(J)*A(J,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 + DO 70 I = N,J + 1,-1 + X(IX) = X(IX) + TEMP*A(I,J) + IX = IX - INCX + 70 CONTINUE + IF (NOUNIT) X(JX) = X(JX)*A(J,J) + END IF + JX = JX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A**T*x or x := A**H*x. +* + IF (LSAME(UPLO,'U')) THEN + IF (INCX.EQ.1) THEN + DO 110 J = N,1,-1 + TEMP = X(J) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 90 I = J - 1,1,-1 + TEMP = TEMP + A(I,J)*X(I) + 90 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) + DO 100 I = J - 1,1,-1 + TEMP = TEMP + DCONJG(A(I,J))*X(I) + 100 CONTINUE + END IF + X(J) = TEMP + 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*A(J,J) + DO 120 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + A(I,J)*X(IX) + 120 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) + DO 130 I = J - 1,1,-1 + IX = IX - INCX + TEMP = TEMP + DCONJG(A(I,J))*X(IX) + 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) + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 150 I = J + 1,N + TEMP = TEMP + A(I,J)*X(I) + 150 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) + DO 160 I = J + 1,N + TEMP = TEMP + DCONJG(A(I,J))*X(I) + 160 CONTINUE + END IF + X(J) = TEMP + 170 CONTINUE + ELSE + JX = KX + DO 200 J = 1,N + TEMP = X(JX) + IX = JX + IF (NOCONJ) THEN + IF (NOUNIT) TEMP = TEMP*A(J,J) + DO 180 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + A(I,J)*X(IX) + 180 CONTINUE + ELSE + IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J)) + DO 190 I = J + 1,N + IX = IX + INCX + TEMP = TEMP + DCONJG(A(I,J))*X(IX) + 190 CONTINUE + END IF + X(JX) = TEMP + JX = JX + INCX + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTRMV +* + END diff --git a/src/ztrsm.c b/src/ztrsm.c new file mode 100644 index 0000000..7f7eb52 --- /dev/null +++ b/src/ztrsm.c @@ -0,0 +1,474 @@ +*> \brief \b ZTRSM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA +* INTEGER LDA,LDB,M,N +* CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRSM 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*16 +*> 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*16 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*16 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 complex16_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 ZTRSM(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*16 ALPHA + INTEGER LDA,LDB,M,N + CHARACTER DIAG,SIDE,TRANSA,UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,K,NROWA + LOGICAL LSIDE,NOCONJ,NOUNIT,UPPER +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+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('ZTRSM ',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 - DCONJG(A(K,I))*B(K,J) + 120 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(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 - DCONJG(A(K,I))*B(K,J) + 160 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(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/DCONJG(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 = DCONJG(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/DCONJG(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 = DCONJG(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 ZTRSM +* + END diff --git a/src/ztrsv.c b/src/ztrsv.c new file mode 100644 index 0000000..0bb9cbe --- /dev/null +++ b/src/ztrsv.c @@ -0,0 +1,372 @@ +*> \brief \b ZTRSV +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX) +* +* .. Scalar Arguments .. +* INTEGER INCX,LDA,N +* CHARACTER DIAG,TRANS,UPLO +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),X(*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZTRSV 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*16 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*16 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 complex16_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 ZTRSV(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*16 A(LDA,*),X(*) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,IX,J,JX,KX + LOGICAL NOCONJ,NOUNIT +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,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('ZTRSV ',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 - DCONJG(A(I,J))*X(I) + 100 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(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 - DCONJG(A(I,J))*X(IX) + IX = IX + INCX + 130 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(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 - DCONJG(A(I,J))*X(I) + 160 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(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 - DCONJG(A(I,J))*X(IX) + IX = IX - INCX + 190 CONTINUE + IF (NOUNIT) TEMP = TEMP/DCONJG(A(J,J)) + END IF + X(JX) = TEMP + JX = JX - INCX + 200 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of ZTRSV +* + END