diff options
author | shmel1k <shmel1k@ydb.tech> | 2022-09-02 12:44:59 +0300 |
---|---|---|
committer | shmel1k <shmel1k@ydb.tech> | 2022-09-02 12:44:59 +0300 |
commit | 90d450f74722da7859d6f510a869f6c6908fd12f (patch) | |
tree | 538c718dedc76cdfe37ad6d01ff250dd930d9278 /contrib/libs/clapack/zlaqhe.c | |
parent | 01f64c1ecd0d4ffa9e3a74478335f1745f26cc75 (diff) | |
download | ydb-90d450f74722da7859d6f510a869f6c6908fd12f.tar.gz |
[] add metering mode to CLI
Diffstat (limited to 'contrib/libs/clapack/zlaqhe.c')
-rw-r--r-- | contrib/libs/clapack/zlaqhe.c | 193 |
1 files changed, 193 insertions, 0 deletions
diff --git a/contrib/libs/clapack/zlaqhe.c b/contrib/libs/clapack/zlaqhe.c new file mode 100644 index 0000000000..b77fc0aa91 --- /dev/null +++ b/contrib/libs/clapack/zlaqhe.c @@ -0,0 +1,193 @@ +/* zlaqhe.f -- translated by f2c (version 20061008). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#include "f2c.h" +#include "blaswrap.h" + +/* Subroutine */ int zlaqhe_(char *uplo, integer *n, doublecomplex *a, + integer *lda, doublereal *s, doublereal *scond, doublereal *amax, + char *equed) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + doublereal d__1; + doublecomplex z__1; + + /* Local variables */ + integer i__, j; + doublereal cj, large; + extern logical lsame_(char *, char *); + doublereal small; + extern doublereal dlamch_(char *); + + +/* -- LAPACK auxiliary routine (version 3.2) -- */ +/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ +/* November 2006 */ + +/* .. Scalar Arguments .. */ +/* .. */ +/* .. Array Arguments .. */ +/* .. */ + +/* Purpose */ +/* ======= */ + +/* ZLAQHE equilibrates a Hermitian matrix A using the scaling factors */ +/* in the vector S. */ + +/* Arguments */ +/* ========= */ + +/* UPLO (input) CHARACTER*1 */ +/* Specifies whether the upper or lower triangular part of the */ +/* Hermitian matrix A is stored. */ +/* = 'U': Upper triangular */ +/* = 'L': Lower triangular */ + +/* N (input) INTEGER */ +/* The order of the matrix A. N >= 0. */ + +/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */ +/* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */ +/* n by n upper triangular part of A contains the upper */ +/* triangular part of the matrix A, and the strictly lower */ +/* triangular part of A is not referenced. If UPLO = 'L', the */ +/* leading n by n lower triangular part of A contains the lower */ +/* triangular part of the matrix A, and the strictly upper */ +/* triangular part of A is not referenced. */ + +/* On exit, if EQUED = 'Y', the equilibrated matrix: */ +/* diag(S) * A * diag(S). */ + +/* LDA (input) INTEGER */ +/* The leading dimension of the array A. LDA >= max(N,1). */ + +/* S (input) DOUBLE PRECISION array, dimension (N) */ +/* The scale factors for A. */ + +/* SCOND (input) DOUBLE PRECISION */ +/* Ratio of the smallest S(i) to the largest S(i). */ + +/* AMAX (input) DOUBLE PRECISION */ +/* Absolute value of largest matrix entry. */ + +/* EQUED (output) CHARACTER*1 */ +/* Specifies whether or not equilibration was done. */ +/* = 'N': No equilibration. */ +/* = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* diag(S) * A * diag(S). */ + +/* Internal Parameters */ +/* =================== */ + +/* THRESH is a threshold value used to decide if scaling should be done */ +/* based on the ratio of the scaling factors. If SCOND < THRESH, */ +/* scaling is done. */ + +/* LARGE and SMALL are threshold values used to decide if scaling should */ +/* be done based on the absolute size of the largest matrix element. */ +/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */ + +/* ===================================================================== */ + +/* .. Parameters .. */ +/* .. */ +/* .. Local Scalars .. */ +/* .. */ +/* .. External Functions .. */ +/* .. */ +/* .. Intrinsic Functions .. */ +/* .. */ +/* .. Executable Statements .. */ + +/* Quick return if possible */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --s; + + /* Function Body */ + if (*n <= 0) { + *(unsigned char *)equed = 'N'; + return 0; + } + +/* Initialize LARGE and SMALL. */ + + small = dlamch_("Safe minimum") / dlamch_("Precision"); + large = 1. / small; + + if (*scond >= .1 && *amax >= small && *amax <= large) { + +/* No equilibration */ + + *(unsigned char *)equed = 'N'; + } else { + +/* Replace A by diag(S) * A * diag(S). */ + + if (lsame_(uplo, "U")) { + +/* Upper triangle of A is stored. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + d__1 = cj * s[i__]; + i__4 = i__ + j * a_dim1; + z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L10: */ + } + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + d__1 = cj * cj * a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; +/* L20: */ + } + } else { + +/* Lower triangle of A is stored. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + d__1 = cj * cj * a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + d__1 = cj * s[i__]; + i__4 = i__ + j * a_dim1; + z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L30: */ + } +/* L40: */ + } + } + *(unsigned char *)equed = 'Y'; + } + + return 0; + +/* End of ZLAQHE */ + +} /* zlaqhe_ */ |