floraachy
/
OpenBLAS
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
OpenBLAS/lapack-netlib/SRC/sla_gbamv.f

408 lines
12 KiB
Fortran
Raw Blame History

*> \brief \b SLA_GBAMV performs a matrix-vector operation to calculate error bounds.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLA_GBAMV + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sla_gbamv.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sla_gbamv.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sla_gbamv.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X,
* INCX, BETA, Y, INCY )
*
* .. Scalar Arguments ..
* REAL ALPHA, BETA
* INTEGER INCX, INCY, LDAB, M, N, KL, KU, TRANS
* ..
* .. Array Arguments ..
* REAL AB( LDAB, * ), X( * ), Y( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLA_GBAMV performs one of the matrix-vector operations
*>
*> y := alpha*abs(A)*abs(x) + beta*abs(y),
*> or y := alpha*abs(A)**T*abs(x) + beta*abs(y),
*>
*> where alpha and beta are scalars, x and y are vectors and A is an
*> m by n matrix.
*>
*> This function is primarily used in calculating error bounds.
*> To protect against underflow during evaluation, components in
*> the resulting vector are perturbed away from zero by (N+1)
*> times the underflow threshold. To prevent unnecessarily large
*> errors for block-structure embedded in general matrices,
*> "symbolically" zero components are not perturbed. A zero
*> entry is considered "symbolic" if all multiplications involved
*> in computing that entry have at least one zero multiplicand.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANS
*> \verbatim
*> TRANS is INTEGER
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)
*> BLAS_TRANS y := alpha*abs(A**T)*abs(x) + beta*abs(y)
*> BLAS_CONJ_TRANS y := alpha*abs(A**T)*abs(x) + beta*abs(y)
*>
*> Unchanged on exit.
*> \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.
*> Unchanged on exit.
*> \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.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*> KL is INTEGER
*> The number of subdiagonals within the band of A. KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*> KU is INTEGER
*> The number of superdiagonals within the band of A. KU >= 0.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is REAL
*> On entry, ALPHA specifies the scalar alpha.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] AB
*> \verbatim
*> AB is REAL array, dimension ( LDAB, n )
*> Before entry, the leading m by n part of the array AB must
*> contain the matrix of coefficients.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*> LDAB is INTEGER
*> On entry, LDA specifies the first dimension of AB as declared
*> in the calling (sub) program. LDAB must be at least
*> max( 1, m ).
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is REAL array, dimension
*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
*> and at least
*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
*> Before entry, the incremented array X must contain the
*> vector x.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> Unchanged on exit.
*> \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.
*> Unchanged on exit.
*> \endverbatim
*>
*> \param[in,out] Y
*> \verbatim
*> Y is REAL array, dimension
*> ( 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.
*> Unchanged on exit.
*>
*> Level 2 Blas routine.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup realGBcomputational
*
* =====================================================================
SUBROUTINE SLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X,
$ INCX, BETA, Y, INCY )
*
* -- LAPACK computational routine --
* -- LAPACK 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, LDAB, M, N, KL, KU, TRANS
* ..
* .. Array Arguments ..
REAL AB( LDAB, * ), X( * ), Y( * )
* ..
*
* =====================================================================
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
LOGICAL SYMB_ZERO
REAL TEMP, SAFE1
INTEGER I, INFO, IY, J, JX, KX, KY, LENX, LENY, KD, KE
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, SLAMCH
REAL SLAMCH
* ..
* .. External Functions ..
EXTERNAL ILATRANS
INTEGER ILATRANS
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, ABS, SIGN
* ..
* .. Executable Statements ..
*
* Test the input parameters.
*
INFO = 0
IF ( .NOT.( ( TRANS.EQ.ILATRANS( 'N' ) )
$ .OR. ( TRANS.EQ.ILATRANS( 'T' ) )
$ .OR. ( TRANS.EQ.ILATRANS( '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 .OR. KL.GT.M-1 ) THEN
INFO = 4
ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN
INFO = 5
ELSE IF( LDAB.LT.KL+KU+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( 'SLA_GBAMV ', 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( TRANS.EQ.ILATRANS( '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
*
* Set SAFE1 essentially to be the underflow threshold times the
* number of additions in each row.
*
SAFE1 = SLAMCH( 'Safe minimum' )
SAFE1 = (N+1)*SAFE1
*
* Form y := alpha*abs(A)*abs(x) + beta*abs(y).
*
* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to
* the inexact flag. Still doesn't help change the iteration order
* to per-column.
*
KD = KU + 1
KE = KL + 1
IY = KY
IF ( INCX.EQ.1 ) THEN
IF( TRANS.EQ.ILATRANS( 'N' ) )THEN
DO I = 1, LENY
IF ( BETA .EQ. ZERO ) THEN
SYMB_ZERO = .TRUE.
Y( IY ) = 0.0
ELSE IF ( Y( IY ) .EQ. ZERO ) THEN
SYMB_ZERO = .TRUE.
ELSE
SYMB_ZERO = .FALSE.
Y( IY ) = BETA * ABS( Y( IY ) )
END IF
IF ( ALPHA .NE. ZERO ) THEN
DO J = MAX( I-KL, 1 ), MIN( I+KU, LENX )
TEMP = ABS( AB( KD+I-J, J ) )
SYMB_ZERO = SYMB_ZERO .AND.
$ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO )
Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP
END DO
END IF
IF ( .NOT.SYMB_ZERO )
$ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) )
IY = IY + INCY
END DO
ELSE
DO I = 1, LENY
IF ( BETA .EQ. ZERO ) THEN
SYMB_ZERO = .TRUE.
Y( IY ) = 0.0
ELSE IF ( Y( IY ) .EQ. ZERO ) THEN
SYMB_ZERO = .TRUE.
ELSE
SYMB_ZERO = .FALSE.
Y( IY ) = BETA * ABS( Y( IY ) )
END IF
IF ( ALPHA .NE. ZERO ) THEN
DO J = MAX( I-KL, 1 ), MIN( I+KU, LENX )
TEMP = ABS( AB( KE-I+J, I ) )
SYMB_ZERO = SYMB_ZERO .AND.
$ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO )
Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP
END DO
END IF
IF ( .NOT.SYMB_ZERO )
$ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) )
IY = IY + INCY
END DO
END IF
ELSE
IF( TRANS.EQ.ILATRANS( 'N' ) )THEN
DO I = 1, LENY
IF ( BETA .EQ. ZERO ) THEN
SYMB_ZERO = .TRUE.
Y( IY ) = 0.0
ELSE IF ( Y( IY ) .EQ. ZERO ) THEN
SYMB_ZERO = .TRUE.
ELSE
SYMB_ZERO = .FALSE.
Y( IY ) = BETA * ABS( Y( IY ) )
END IF
IF ( ALPHA .NE. ZERO ) THEN
JX = KX
DO J = MAX( I-KL, 1 ), MIN( I+KU, LENX )
TEMP = ABS( AB( KD+I-J, J ) )
SYMB_ZERO = SYMB_ZERO .AND.
$ ( X( JX ) .EQ. ZERO .OR. TEMP .EQ. ZERO )
Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP
JX = JX + INCX
END DO
END IF
IF ( .NOT.SYMB_ZERO )
$ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) )
IY = IY + INCY
END DO
ELSE
DO I = 1, LENY
IF ( BETA .EQ. ZERO ) THEN
SYMB_ZERO = .TRUE.
Y( IY ) = 0.0
ELSE IF ( Y( IY ) .EQ. ZERO ) THEN
SYMB_ZERO = .TRUE.
ELSE
SYMB_ZERO = .FALSE.
Y( IY ) = BETA * ABS( Y( IY ) )
END IF
IF ( ALPHA .NE. ZERO ) THEN
JX = KX
DO J = MAX( I-KL, 1 ), MIN( I+KU, LENX )
TEMP = ABS( AB( KE-I+J, I ) )
SYMB_ZERO = SYMB_ZERO .AND.
$ ( X( JX ) .EQ. ZERO .OR. TEMP .EQ. ZERO )
Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP
JX = JX + INCX
END DO
END IF
IF ( .NOT.SYMB_ZERO )
$ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) )
IY = IY + INCY
END DO
END IF
END IF
*
RETURN
*
* End of SLA_GBAMV
*
END
Reference in New Issue View Git Blame Copy Permalink