|
1
2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 |
SUBROUTINE CLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
$ LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM, $ GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, $ INFO ) * * -- LAPACK routine (version 3.3.1) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * -- April 2011 -- * * .. Scalar Arguments .. INTEGER CURLVL, CURPBM, CUTPNT, INFO, LDQ, N, QSIZ, $ TLVLS REAL RHO * .. * .. Array Arguments .. INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) REAL D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * ) COMPLEX Q( LDQ, * ), WORK( * ) * .. * * Purpose * ======= * * CLAED7 computes the updated eigensystem of a diagonal * matrix after modification by a rank-one symmetric matrix. This * routine is used only for the eigenproblem which requires all * eigenvalues and optionally eigenvectors of a dense or banded * Hermitian matrix that has been reduced to tridiagonal form. * * T = Q(in) ( D(in) + RHO * Z*Z**H ) Q**H(in) = Q(out) * D(out) * Q**H(out) * * where Z = Q**Hu, u is a vector of length N with ones in the * CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. * * The eigenvectors of the original matrix are stored in Q, and the * eigenvalues are in D. The algorithm consists of three stages: * * The first stage consists of deflating the size of the problem * when there are multiple eigenvalues or if there is a zero in * the Z vector. For each such occurence the dimension of the * secular equation problem is reduced by one. This stage is * performed by the routine SLAED2. * * The second stage consists of calculating the updated * eigenvalues. This is done by finding the roots of the secular * equation via the routine SLAED4 (as called by SLAED3). * This routine also calculates the eigenvectors of the current * problem. * * The final stage consists of computing the updated eigenvectors * directly using the updated eigenvalues. The eigenvectors for * the current problem are multiplied with the eigenvectors from * the overall problem. * * Arguments * ========= * * N (input) INTEGER * The dimension of the symmetric tridiagonal matrix. N >= 0. * * CUTPNT (input) INTEGER * Contains the location of the last eigenvalue in the leading * sub-matrix. min(1,N) <= CUTPNT <= N. * * QSIZ (input) INTEGER * The dimension of the unitary matrix used to reduce * the full matrix to tridiagonal form. QSIZ >= N. * * TLVLS (input) INTEGER * The total number of merging levels in the overall divide and * conquer tree. * * CURLVL (input) INTEGER * The current level in the overall merge routine, * 0 <= curlvl <= tlvls. * * CURPBM (input) INTEGER * The current problem in the current level in the overall * merge routine (counting from upper left to lower right). * * D (input/output) REAL array, dimension (N) * On entry, the eigenvalues of the rank-1-perturbed matrix. * On exit, the eigenvalues of the repaired matrix. * * Q (input/output) COMPLEX array, dimension (LDQ,N) * On entry, the eigenvectors of the rank-1-perturbed matrix. * On exit, the eigenvectors of the repaired tridiagonal matrix. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= max(1,N). * * RHO (input) REAL * Contains the subdiagonal element used to create the rank-1 * modification. * * INDXQ (output) INTEGER array, dimension (N) * This contains the permutation which will reintegrate the * subproblem just solved back into sorted order, * ie. D( INDXQ( I = 1, N ) ) will be in ascending order. * * IWORK (workspace) INTEGER array, dimension (4*N) * * RWORK (workspace) REAL array, * dimension (3*N+2*QSIZ*N) * * WORK (workspace) COMPLEX array, dimension (QSIZ*N) * * QSTORE (input/output) REAL array, dimension (N**2+1) * Stores eigenvectors of submatrices encountered during * divide and conquer, packed together. QPTR points to * beginning of the submatrices. * * QPTR (input/output) INTEGER array, dimension (N+2) * List of indices pointing to beginning of submatrices stored * in QSTORE. The submatrices are numbered starting at the * bottom left of the divide and conquer tree, from left to * right and bottom to top. * * PRMPTR (input) INTEGER array, dimension (N lg N) * Contains a list of pointers which indicate where in PERM a * level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) * indicates the size of the permutation and also the size of * the full, non-deflated problem. * * PERM (input) INTEGER array, dimension (N lg N) * Contains the permutations (from deflation and sorting) to be * applied to each eigenblock. * * GIVPTR (input) INTEGER array, dimension (N lg N) * Contains a list of pointers which indicate where in GIVCOL a * level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) * indicates the number of Givens rotations. * * GIVCOL (input) INTEGER array, dimension (2, N lg N) * Each pair of numbers indicates a pair of columns to take place * in a Givens rotation. * * GIVNUM (input) REAL array, dimension (2, N lg N) * Each number indicates the S value to be used in the * corresponding Givens rotation. * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * > 0: if INFO = 1, an eigenvalue did not converge * * ===================================================================== * * .. Local Scalars .. INTEGER COLTYP, CURR, I, IDLMDA, INDX, $ INDXC, INDXP, IQ, IW, IZ, K, N1, N2, PTR * .. * .. External Subroutines .. EXTERNAL CLACRM, CLAED8, SLAED9, SLAEDA, SLAMRG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * * IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN * INFO = -1 * ELSE IF( N.LT.0 ) THEN IF( N.LT.0 ) THEN INFO = -1 ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN INFO = -2 ELSE IF( QSIZ.LT.N ) THEN INFO = -3 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CLAED7', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * The following values are for bookkeeping purposes only. They are * integer pointers which indicate the portion of the workspace * used by a particular array in SLAED2 and SLAED3. * IZ = 1 IDLMDA = IZ + N IW = IDLMDA + N IQ = IW + N * INDX = 1 INDXC = INDX + N COLTYP = INDXC + N INDXP = COLTYP + N * * Form the z-vector which consists of the last row of Q_1 and the * first row of Q_2. * PTR = 1 + 2**TLVLS DO 10 I = 1, CURLVL - 1 PTR = PTR + 2**( TLVLS-I ) 10 CONTINUE CURR = PTR + CURPBM CALL SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, $ GIVCOL, GIVNUM, QSTORE, QPTR, RWORK( IZ ), $ RWORK( IZ+N ), INFO ) * * When solving the final problem, we no longer need the stored data, * so we will overwrite the data from this level onto the previously * used storage space. * IF( CURLVL.EQ.TLVLS ) THEN QPTR( CURR ) = 1 PRMPTR( CURR ) = 1 GIVPTR( CURR ) = 1 END IF * * Sort and Deflate eigenvalues. * CALL CLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, RWORK( IZ ), $ RWORK( IDLMDA ), WORK, QSIZ, RWORK( IW ), $ IWORK( INDXP ), IWORK( INDX ), INDXQ, $ PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ), $ GIVCOL( 1, GIVPTR( CURR ) ), $ GIVNUM( 1, GIVPTR( CURR ) ), INFO ) PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR ) * * Solve Secular Equation. * IF( K.NE.0 ) THEN CALL SLAED9( K, 1, K, N, D, RWORK( IQ ), K, RHO, $ RWORK( IDLMDA ), RWORK( IW ), $ QSTORE( QPTR( CURR ) ), K, INFO ) CALL CLACRM( QSIZ, K, WORK, QSIZ, QSTORE( QPTR( CURR ) ), K, Q, $ LDQ, RWORK( IQ ) ) QPTR( CURR+1 ) = QPTR( CURR ) + K**2 IF( INFO.NE.0 ) THEN RETURN END IF * * Prepare the INDXQ sorting premutation. * N1 = K N2 = N - K CALL SLAMRG( N1, N2, D, 1, -1, INDXQ ) ELSE QPTR( CURR+1 ) = QPTR( CURR ) DO 20 I = 1, N INDXQ( I ) = I 20 CONTINUE END IF * RETURN * * End of CLAED7 * END |