/* slarot.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" /* Table of constant values */ static integer c__4 = 4; static integer c__8 = 8; static integer c__1 = 1; /* Subroutine */ int slarot_(logical *lrows, logical *lleft, logical *lright, integer *nl, real *c__, real *s, real *a, integer *lda, real *xleft, real *xright) { /* System generated locals */ integer i__1; /* Local variables */ integer ix, iy, nt; real xt[2], yt[2]; integer iyt, iinc; extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, integer *, real *, real *); integer inext; extern /* Subroutine */ int xerbla_(char *, integer *); /* -- LAPACK auxiliary test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* SLAROT applies a (Givens) rotation to two adjacent rows or */ /* columns, where one element of the first and/or last column/row */ /* for use on matrices stored in some format other than GE, so */ /* that elements of the matrix may be used or modified for which */ /* no array element is provided. */ /* One example is a symmetric matrix in SB format (bandwidth=4), for */ /* which UPLO='L': Two adjacent rows will have the format: */ /* row j: * * * * * . . . . */ /* row j+1: * * * * * . . . . */ /* '*' indicates elements for which storage is provided, */ /* '.' indicates elements for which no storage is provided, but */ /* are not necessarily zero; their values are determined by */ /* symmetry. ' ' indicates elements which are necessarily zero, */ /* and have no storage provided. */ /* Those columns which have two '*'s can be handled by SROT. */ /* Those columns which have no '*'s can be ignored, since as long */ /* as the Givens rotations are carefully applied to preserve */ /* symmetry, their values are determined. */ /* Those columns which have one '*' have to be handled separately, */ /* by using separate variables "p" and "q": */ /* row j: * * * * * p . . . */ /* row j+1: q * * * * * . . . . */ /* The element p would have to be set correctly, then that column */ /* is rotated, setting p to its new value. The next call to */ /* SLAROT would rotate columns j and j+1, using p, and restore */ /* symmetry. The element q would start out being zero, and be */ /* made non-zero by the rotation. Later, rotations would presumably */ /* be chosen to zero q out. */ /* Typical Calling Sequences: rotating the i-th and (i+1)-st rows. */ /* ------- ------- --------- */ /* General dense matrix: */ /* CALL SLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S, */ /* A(i,1),LDA, DUMMY, DUMMY) */ /* General banded matrix in GB format: */ /* j = MAX(1, i-KL ) */ /* NL = MIN( N, i+KU+1 ) + 1-j */ /* CALL SLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S, */ /* A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT ) */ /* [ note that i+1-j is just MIN(i,KL+1) ] */ /* Symmetric banded matrix in SY format, bandwidth K, */ /* lower triangle only: */ /* j = MAX(1, i-K ) */ /* NL = MIN( K+1, i ) + 1 */ /* CALL SLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S, */ /* A(i,j), LDA, XLEFT, XRIGHT ) */ /* Same, but upper triangle only: */ /* NL = MIN( K+1, N-i ) + 1 */ /* CALL SLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S, */ /* A(i,i), LDA, XLEFT, XRIGHT ) */ /* Symmetric banded matrix in SB format, bandwidth K, */ /* lower triangle only: */ /* [ same as for SY, except:] */ /* . . . . */ /* A(i+1-j,j), LDA-1, XLEFT, XRIGHT ) */ /* [ note that i+1-j is just MIN(i,K+1) ] */ /* Same, but upper triangle only: */ /* . . . */ /* A(K+1,i), LDA-1, XLEFT, XRIGHT ) */ /* Rotating columns is just the transpose of rotating rows, except */ /* for GB and SB: (rotating columns i and i+1) */ /* GB: */ /* j = MAX(1, i-KU ) */ /* NL = MIN( N, i+KL+1 ) + 1-j */ /* CALL SLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S, */ /* A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM ) */ /* [note that KU+j+1-i is just MAX(1,KU+2-i)] */ /* SB: (upper triangle) */ /* . . . . . . */ /* A(K+j+1-i,i),LDA-1, XTOP, XBOTTM ) */ /* SB: (lower triangle) */ /* . . . . . . */ /* A(1,i),LDA-1, XTOP, XBOTTM ) */ /* Arguments */ /* ========= */ /* LROWS - LOGICAL */ /* If .TRUE., then SLAROT will rotate two rows. If .FALSE., */ /* then it will rotate two columns. */ /* Not modified. */ /* LLEFT - LOGICAL */ /* If .TRUE., then XLEFT will be used instead of the */ /* corresponding element of A for the first element in the */ /* second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) */ /* If .FALSE., then the corresponding element of A will be */ /* used. */ /* Not modified. */ /* LRIGHT - LOGICAL */ /* If .TRUE., then XRIGHT will be used instead of the */ /* corresponding element of A for the last element in the */ /* first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If */ /* .FALSE., then the corresponding element of A will be used. */ /* Not modified. */ /* NL - INTEGER */ /* The length of the rows (if LROWS=.TRUE.) or columns (if */ /* LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are */ /* used, the columns/rows they are in should be included in */ /* NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at */ /* least 2. The number of rows/columns to be rotated */ /* exclusive of those involving XLEFT and/or XRIGHT may */ /* not be negative, i.e., NL minus how many of LLEFT and */ /* LRIGHT are .TRUE. must be at least zero; if not, XERBLA */ /* will be called. */ /* Not modified. */ /* C, S - REAL */ /* Specify the Givens rotation to be applied. If LROWS is */ /* true, then the matrix ( c s ) */ /* (-s c ) is applied from the left; */ /* if false, then the transpose thereof is applied from the */ /* right. For a Givens rotation, C**2 + S**2 should be 1, */ /* but this is not checked. */ /* Not modified. */ /* A - REAL array. */ /* The array containing the rows/columns to be rotated. The */ /* first element of A should be the upper left element to */ /* be rotated. */ /* Read and modified. */ /* LDA - INTEGER */ /* The "effective" leading dimension of A. If A contains */ /* a matrix stored in GE or SY format, then this is just */ /* the leading dimension of A as dimensioned in the calling */ /* routine. If A contains a matrix stored in band (GB or SB) */ /* format, then this should be *one less* than the leading */ /* dimension used in the calling routine. Thus, if */ /* A were dimensioned A(LDA,*) in SLAROT, then A(1,j) would */ /* be the j-th element in the first of the two rows */ /* to be rotated, and A(2,j) would be the j-th in the second, */ /* regardless of how the array may be stored in the calling */ /* routine. [A cannot, however, actually be dimensioned thus, */ /* since for band format, the row number may exceed LDA, which */ /* is not legal FORTRAN.] */ /* If LROWS=.TRUE., then LDA must be at least 1, otherwise */ /* it must be at least NL minus the number of .TRUE. values */ /* in XLEFT and XRIGHT. */ /* Not modified. */ /* XLEFT - REAL */ /* If LLEFT is .TRUE., then XLEFT will be used and modified */ /* instead of A(2,1) (if LROWS=.TRUE.) or A(1,2) */ /* (if LROWS=.FALSE.). */ /* Read and modified. */ /* XRIGHT - REAL */ /* If LRIGHT is .TRUE., then XRIGHT will be used and modified */ /* instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1) */ /* (if LROWS=.FALSE.). */ /* Read and modified. */ /* ===================================================================== */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Executable Statements .. */ /* Set up indices, arrays for ends */ /* Parameter adjustments */ --a; /* Function Body */ if (*lrows) { iinc = *lda; inext = 1; } else { iinc = 1; inext = *lda; } if (*lleft) { nt = 1; ix = iinc + 1; iy = *lda + 2; xt[0] = a[1]; yt[0] = *xleft; } else { nt = 0; ix = 1; iy = inext + 1; } if (*lright) { iyt = inext + 1 + (*nl - 1) * iinc; ++nt; xt[nt - 1] = *xright; yt[nt - 1] = a[iyt]; } /* Check for errors */ if (*nl < nt) { xerbla_("SLAROT", &c__4); return 0; } if (*lda <= 0 || ! (*lrows) && *lda < *nl - nt) { xerbla_("SLAROT", &c__8); return 0; } /* Rotate */ i__1 = *nl - nt; srot_(&i__1, &a[ix], &iinc, &a[iy], &iinc, c__, s); srot_(&nt, xt, &c__1, yt, &c__1, c__, s); /* Stuff values back into XLEFT, XRIGHT, etc. */ if (*lleft) { a[1] = xt[0]; *xleft = yt[0]; } if (*lright) { *xright = xt[nt - 1]; a[iyt] = yt[nt - 1]; } return 0; /* End of SLAROT */ } /* slarot_ */