00001 /* slarot.f -- translated by f2c (version 20061008). 00002 You must link the resulting object file with libf2c: 00003 on Microsoft Windows system, link with libf2c.lib; 00004 on Linux or Unix systems, link with .../path/to/libf2c.a -lm 00005 or, if you install libf2c.a in a standard place, with -lf2c -lm 00006 -- in that order, at the end of the command line, as in 00007 cc *.o -lf2c -lm 00008 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., 00009 00010 http://www.netlib.org/f2c/libf2c.zip 00011 */ 00012 00013 #include "f2c.h" 00014 #include "blaswrap.h" 00015 00016 /* Table of constant values */ 00017 00018 static integer c__4 = 4; 00019 static integer c__8 = 8; 00020 static integer c__1 = 1; 00021 00022 /* Subroutine */ int slarot_(logical *lrows, logical *lleft, logical *lright, 00023 integer *nl, real *c__, real *s, real *a, integer *lda, real *xleft, 00024 real *xright) 00025 { 00026 /* System generated locals */ 00027 integer i__1; 00028 00029 /* Local variables */ 00030 integer ix, iy, nt; 00031 real xt[2], yt[2]; 00032 integer iyt, iinc; 00033 extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, 00034 integer *, real *, real *); 00035 integer inext; 00036 extern /* Subroutine */ int xerbla_(char *, integer *); 00037 00038 00039 /* -- LAPACK auxiliary test routine (version 3.1) -- */ 00040 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ 00041 /* November 2006 */ 00042 00043 /* .. Scalar Arguments .. */ 00044 /* .. */ 00045 /* .. Array Arguments .. */ 00046 /* .. */ 00047 00048 /* Purpose */ 00049 /* ======= */ 00050 00051 /* SLAROT applies a (Givens) rotation to two adjacent rows or */ 00052 /* columns, where one element of the first and/or last column/row */ 00053 /* for use on matrices stored in some format other than GE, so */ 00054 /* that elements of the matrix may be used or modified for which */ 00055 /* no array element is provided. */ 00056 00057 /* One example is a symmetric matrix in SB format (bandwidth=4), for */ 00058 /* which UPLO='L': Two adjacent rows will have the format: */ 00059 00060 /* row j: * * * * * . . . . */ 00061 /* row j+1: * * * * * . . . . */ 00062 00063 /* '*' indicates elements for which storage is provided, */ 00064 /* '.' indicates elements for which no storage is provided, but */ 00065 /* are not necessarily zero; their values are determined by */ 00066 /* symmetry. ' ' indicates elements which are necessarily zero, */ 00067 /* and have no storage provided. */ 00068 00069 /* Those columns which have two '*'s can be handled by SROT. */ 00070 /* Those columns which have no '*'s can be ignored, since as long */ 00071 /* as the Givens rotations are carefully applied to preserve */ 00072 /* symmetry, their values are determined. */ 00073 /* Those columns which have one '*' have to be handled separately, */ 00074 /* by using separate variables "p" and "q": */ 00075 00076 /* row j: * * * * * p . . . */ 00077 /* row j+1: q * * * * * . . . . */ 00078 00079 /* The element p would have to be set correctly, then that column */ 00080 /* is rotated, setting p to its new value. The next call to */ 00081 /* SLAROT would rotate columns j and j+1, using p, and restore */ 00082 /* symmetry. The element q would start out being zero, and be */ 00083 /* made non-zero by the rotation. Later, rotations would presumably */ 00084 /* be chosen to zero q out. */ 00085 00086 /* Typical Calling Sequences: rotating the i-th and (i+1)-st rows. */ 00087 /* ------- ------- --------- */ 00088 00089 /* General dense matrix: */ 00090 00091 /* CALL SLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S, */ 00092 /* A(i,1),LDA, DUMMY, DUMMY) */ 00093 00094 /* General banded matrix in GB format: */ 00095 00096 /* j = MAX(1, i-KL ) */ 00097 /* NL = MIN( N, i+KU+1 ) + 1-j */ 00098 /* CALL SLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S, */ 00099 /* A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT ) */ 00100 00101 /* [ note that i+1-j is just MIN(i,KL+1) ] */ 00102 00103 /* Symmetric banded matrix in SY format, bandwidth K, */ 00104 /* lower triangle only: */ 00105 00106 /* j = MAX(1, i-K ) */ 00107 /* NL = MIN( K+1, i ) + 1 */ 00108 /* CALL SLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S, */ 00109 /* A(i,j), LDA, XLEFT, XRIGHT ) */ 00110 00111 /* Same, but upper triangle only: */ 00112 00113 /* NL = MIN( K+1, N-i ) + 1 */ 00114 /* CALL SLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S, */ 00115 /* A(i,i), LDA, XLEFT, XRIGHT ) */ 00116 00117 /* Symmetric banded matrix in SB format, bandwidth K, */ 00118 /* lower triangle only: */ 00119 00120 /* [ same as for SY, except:] */ 00121 /* . . . . */ 00122 /* A(i+1-j,j), LDA-1, XLEFT, XRIGHT ) */ 00123 00124 /* [ note that i+1-j is just MIN(i,K+1) ] */ 00125 00126 /* Same, but upper triangle only: */ 00127 /* . . . */ 00128 /* A(K+1,i), LDA-1, XLEFT, XRIGHT ) */ 00129 00130 /* Rotating columns is just the transpose of rotating rows, except */ 00131 /* for GB and SB: (rotating columns i and i+1) */ 00132 00133 /* GB: */ 00134 /* j = MAX(1, i-KU ) */ 00135 /* NL = MIN( N, i+KL+1 ) + 1-j */ 00136 /* CALL SLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S, */ 00137 /* A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM ) */ 00138 00139 /* [note that KU+j+1-i is just MAX(1,KU+2-i)] */ 00140 00141 /* SB: (upper triangle) */ 00142 00143 /* . . . . . . */ 00144 /* A(K+j+1-i,i),LDA-1, XTOP, XBOTTM ) */ 00145 00146 /* SB: (lower triangle) */ 00147 00148 /* . . . . . . */ 00149 /* A(1,i),LDA-1, XTOP, XBOTTM ) */ 00150 00151 /* Arguments */ 00152 /* ========= */ 00153 00154 /* LROWS - LOGICAL */ 00155 /* If .TRUE., then SLAROT will rotate two rows. If .FALSE., */ 00156 /* then it will rotate two columns. */ 00157 /* Not modified. */ 00158 00159 /* LLEFT - LOGICAL */ 00160 /* If .TRUE., then XLEFT will be used instead of the */ 00161 /* corresponding element of A for the first element in the */ 00162 /* second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) */ 00163 /* If .FALSE., then the corresponding element of A will be */ 00164 /* used. */ 00165 /* Not modified. */ 00166 00167 /* LRIGHT - LOGICAL */ 00168 /* If .TRUE., then XRIGHT will be used instead of the */ 00169 /* corresponding element of A for the last element in the */ 00170 /* first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If */ 00171 /* .FALSE., then the corresponding element of A will be used. */ 00172 /* Not modified. */ 00173 00174 /* NL - INTEGER */ 00175 /* The length of the rows (if LROWS=.TRUE.) or columns (if */ 00176 /* LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are */ 00177 /* used, the columns/rows they are in should be included in */ 00178 /* NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at */ 00179 /* least 2. The number of rows/columns to be rotated */ 00180 /* exclusive of those involving XLEFT and/or XRIGHT may */ 00181 /* not be negative, i.e., NL minus how many of LLEFT and */ 00182 /* LRIGHT are .TRUE. must be at least zero; if not, XERBLA */ 00183 /* will be called. */ 00184 /* Not modified. */ 00185 00186 /* C, S - REAL */ 00187 /* Specify the Givens rotation to be applied. If LROWS is */ 00188 /* true, then the matrix ( c s ) */ 00189 /* (-s c ) is applied from the left; */ 00190 /* if false, then the transpose thereof is applied from the */ 00191 /* right. For a Givens rotation, C**2 + S**2 should be 1, */ 00192 /* but this is not checked. */ 00193 /* Not modified. */ 00194 00195 /* A - REAL array. */ 00196 /* The array containing the rows/columns to be rotated. The */ 00197 /* first element of A should be the upper left element to */ 00198 /* be rotated. */ 00199 /* Read and modified. */ 00200 00201 /* LDA - INTEGER */ 00202 /* The "effective" leading dimension of A. If A contains */ 00203 /* a matrix stored in GE or SY format, then this is just */ 00204 /* the leading dimension of A as dimensioned in the calling */ 00205 /* routine. If A contains a matrix stored in band (GB or SB) */ 00206 /* format, then this should be *one less* than the leading */ 00207 /* dimension used in the calling routine. Thus, if */ 00208 /* A were dimensioned A(LDA,*) in SLAROT, then A(1,j) would */ 00209 /* be the j-th element in the first of the two rows */ 00210 /* to be rotated, and A(2,j) would be the j-th in the second, */ 00211 /* regardless of how the array may be stored in the calling */ 00212 /* routine. [A cannot, however, actually be dimensioned thus, */ 00213 /* since for band format, the row number may exceed LDA, which */ 00214 /* is not legal FORTRAN.] */ 00215 /* If LROWS=.TRUE., then LDA must be at least 1, otherwise */ 00216 /* it must be at least NL minus the number of .TRUE. values */ 00217 /* in XLEFT and XRIGHT. */ 00218 /* Not modified. */ 00219 00220 /* XLEFT - REAL */ 00221 /* If LLEFT is .TRUE., then XLEFT will be used and modified */ 00222 /* instead of A(2,1) (if LROWS=.TRUE.) or A(1,2) */ 00223 /* (if LROWS=.FALSE.). */ 00224 /* Read and modified. */ 00225 00226 /* XRIGHT - REAL */ 00227 /* If LRIGHT is .TRUE., then XRIGHT will be used and modified */ 00228 /* instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1) */ 00229 /* (if LROWS=.FALSE.). */ 00230 /* Read and modified. */ 00231 00232 /* ===================================================================== */ 00233 00234 /* .. Local Scalars .. */ 00235 /* .. */ 00236 /* .. Local Arrays .. */ 00237 /* .. */ 00238 /* .. External Subroutines .. */ 00239 /* .. */ 00240 /* .. Executable Statements .. */ 00241 00242 /* Set up indices, arrays for ends */ 00243 00244 /* Parameter adjustments */ 00245 --a; 00246 00247 /* Function Body */ 00248 if (*lrows) { 00249 iinc = *lda; 00250 inext = 1; 00251 } else { 00252 iinc = 1; 00253 inext = *lda; 00254 } 00255 00256 if (*lleft) { 00257 nt = 1; 00258 ix = iinc + 1; 00259 iy = *lda + 2; 00260 xt[0] = a[1]; 00261 yt[0] = *xleft; 00262 } else { 00263 nt = 0; 00264 ix = 1; 00265 iy = inext + 1; 00266 } 00267 00268 if (*lright) { 00269 iyt = inext + 1 + (*nl - 1) * iinc; 00270 ++nt; 00271 xt[nt - 1] = *xright; 00272 yt[nt - 1] = a[iyt]; 00273 } 00274 00275 /* Check for errors */ 00276 00277 if (*nl < nt) { 00278 xerbla_("SLAROT", &c__4); 00279 return 0; 00280 } 00281 if (*lda <= 0 || ! (*lrows) && *lda < *nl - nt) { 00282 xerbla_("SLAROT", &c__8); 00283 return 0; 00284 } 00285 00286 /* Rotate */ 00287 00288 i__1 = *nl - nt; 00289 srot_(&i__1, &a[ix], &iinc, &a[iy], &iinc, c__, s); 00290 srot_(&nt, xt, &c__1, yt, &c__1, c__, s); 00291 00292 /* Stuff values back into XLEFT, XRIGHT, etc. */ 00293 00294 if (*lleft) { 00295 a[1] = xt[0]; 00296 *xleft = yt[0]; 00297 } 00298 00299 if (*lright) { 00300 *xright = xt[nt - 1]; 00301 a[iyt] = yt[nt - 1]; 00302 } 00303 00304 return 0; 00305 00306 /* End of SLAROT */ 00307 00308 } /* slarot_ */